home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 8: LINUX Games / Linux Cubed Series 8 - LINUX Games.iso / games / role / roleplay.0-s / roleplay / RolePlaying-1.0 / scripts / SYSFunctions < prev    next >
Text File  |  1995-07-09  |  95KB  |  2,655 lines
  1. # Module: SYSFunctions
  2. # Tcl version: 7.3 (Tcl/Tk/XF)
  3. # Tk version: 3.6
  4. # XF version: $__lastrelease$
  5. #
  6.  
  7. # module contents
  8. global moduleList
  9. global autoLoadList
  10. set moduleList(SYSFunctions) { AlertBox AlertBoxFd AlertBoxFile AlertBoxInternal Alias FSBox FSBoxBindSelectOne FSBoxFSFileSelect FSBoxFSFileSelectDouble FSBoxFSInsertPath FSBoxFSNameComplete FSBoxFSShow GetSelection HistoryTextBox InputBoxInternal InputBoxMulti InputBoxOne IsADir IsAFile IsASymlink TextBox TextBoxFd TextBoxFile TextBoxInternal VersionAlertBox YesNoBox Unalias ColorBox}
  11. set autoLoadList(SYSFunctions) {0}
  12.  
  13. # procedures to show toplevel windows
  14.  
  15.  
  16. # User defined procedures
  17.  
  18.  
  19. # Procedure: AlertBox
  20. proc AlertBox { {alertBoxMessage "Alert message"} {alertBoxCommand ""} {alertBoxGeometry "350x150"} {alertBoxTitle "Alert box"} args} {
  21. # xf ignore me 5
  22. ##########
  23. # Procedure: AlertBox
  24. # Description: show alert box
  25. # Arguments: {alertBoxMessage} - the text to display
  26. #            {alertBoxCommand} - the command to call after ok
  27. #            {alertBoxGeometry} - the geometry for the window
  28. #            {alertBoxTitle} - the title for the window
  29. #            {args} - labels of buttons
  30. # Returns: The number of the selected button, ot nothing
  31. # Sideeffects: none
  32. # Notes: there exist also functions called:
  33. #          AlertBoxFile - to open and read a file automatically
  34. #          AlertBoxFd - to read from an already opened filedescriptor
  35. ##########
  36. #
  37. # global alertBox(activeBackground) - active background color
  38. # global alertBox(activeForeground) - active foreground color
  39. # global alertBox(after) - destroy alert box after n seconds
  40. # global alertBox(anchor) - anchor for message box
  41. # global alertBox(background) - background color
  42. # global alertBox(font) - message font
  43. # global alertBox(foreground) - foreground color
  44. # global alertBox(justify) - justify for message box
  45. # global alertBox(toplevelName) - the toplevel name
  46.  
  47.   global alertBox
  48.  
  49.   # show alert box
  50.   if {[llength $args] > 0} {
  51.     eval AlertBoxInternal "\{$alertBoxMessage\}" "\{$alertBoxCommand\}" "\{$alertBoxGeometry\}" "\{$alertBoxTitle\}" $args
  52.   } {
  53.     AlertBoxInternal $alertBoxMessage $alertBoxCommand $alertBoxGeometry $alertBoxTitle
  54.   }
  55.  
  56.   if {[llength $args] > 0} {
  57.     # wait for the box to be destroyed
  58.     update idletask
  59.     grab $alertBox(toplevelName)
  60.     tkwait window $alertBox(toplevelName)
  61.  
  62.     return $alertBox(button)
  63.   }
  64. }
  65.  
  66.  
  67. # Procedure: AlertBoxFd
  68. proc AlertBoxFd { {alertBoxInFile ""} {alertBoxCommand ""} {alertBoxGeometry "350x150"} {alertBoxTitle "Alert box"} args} {
  69. # xf ignore me 5
  70. ##########
  71. # Procedure: AlertBoxFd
  72. # Description: show alert box containing a filedescriptor
  73. # Arguments: {alertBoxInFile} - a filedescriptor to read. The descriptor
  74. #                               is closed after reading
  75. #            {alertBoxCommand} - the command to call after ok
  76. #            {alertBoxGeometry} - the geometry for the window
  77. #            {alertBoxTitle} - the title for the window
  78. #            {args} - labels of buttons
  79. # Returns: The number of the selected button, ot nothing
  80. # Sideeffects: none
  81. # Notes: there exist also functions called:
  82. #          AlertBox - to display a passed string
  83. #          AlertBoxFile - to open and read a file automatically
  84. ##########
  85. #
  86. # global alertBox(activeBackground) - active background color
  87. # global alertBox(activeForeground) - active foreground color
  88. # global alertBox(after) - destroy alert box after n seconds
  89. # global alertBox(anchor) - anchor for message box
  90. # global alertBox(background) - background color
  91. # global alertBox(font) - message font
  92. # global alertBox(foreground) - foreground color
  93. # global alertBox(justify) - justify for message box
  94. # global alertBox(toplevelName) - the toplevel name
  95.  
  96.   global alertBox
  97.  
  98.   # check file existance
  99.   if {"$alertBoxInFile" == ""} {
  100.     puts stderr "No filedescriptor specified"
  101.     return
  102.   }
  103.  
  104.   set alertBoxMessage [read $alertBoxInFile]
  105.   close $alertBoxInFile
  106.  
  107.   # show alert box
  108.   if {[llength $args] > 0} {
  109.     eval AlertBoxInternal "\{$alertBoxMessage\}" "\{$alertBoxCommand\}" "\{$alertBoxGeometry\}" "\{$alertBoxTitle\}" $args
  110.   } {
  111.     AlertBoxInternal $alertBoxMessage $alertBoxCommand $alertBoxGeometry $alertBoxTitle
  112.   }
  113.  
  114.   if {[llength $args] > 0} {
  115.     # wait for the box to be destroyed
  116.     update idletask
  117.     grab $alertBox(toplevelName)
  118.     tkwait window $alertBox(toplevelName)
  119.  
  120.     return $alertBox(button)
  121.   }
  122. }
  123.  
  124.  
  125. # Procedure: AlertBoxFile
  126. proc AlertBoxFile { {alertBoxFile ""} {alertBoxCommand ""} {alertBoxGeometry "350x150"} {alertBoxTitle "Alert box"} args} {
  127. # xf ignore me 5
  128. ##########
  129. # Procedure: AlertBoxFile
  130. # Description: show alert box containing a file
  131. # Arguments: {alertBoxFile} - filename to read
  132. #            {alertBoxCommand} - the command to call after ok
  133. #            {alertBoxGeometry} - the geometry for the window
  134. #            {alertBoxTitle} - the title for the window
  135. #            {args} - labels of buttons
  136. # Returns: The number of the selected button, ot nothing
  137. # Sideeffects: none
  138. # Notes: there exist also functions called:
  139. #          AlertBox - to display a passed string
  140. #          AlertBoxFd - to read from an already opened filedescriptor
  141. ##########
  142. #
  143. # global alertBox(activeBackground) - active background color
  144. # global alertBox(activeForeground) - active foreground color
  145. # global alertBox(after) - destroy alert box after n seconds
  146. # global alertBox(anchor) - anchor for message box
  147. # global alertBox(background) - background color
  148. # global alertBox(font) - message font
  149. # global alertBox(foreground) - foreground color
  150. # global alertBox(justify) - justify for message box
  151. # global alertBox(toplevelName) - the toplevel name
  152.  
  153.   global alertBox
  154.  
  155.   # check file existance
  156.   if {"$alertBoxFile" == ""} {
  157.     puts stderr "No filename specified"
  158.     return
  159.   }
  160.  
  161.   if {[catch "open $alertBoxFile r" alertBoxInFile]} {
  162.     puts stderr "$alertBoxInFile"
  163.     return
  164.   }
  165.  
  166.   set alertBoxMessage [read $alertBoxInFile]
  167.   close $alertBoxInFile
  168.  
  169.   # show alert box
  170.   if {[llength $args] > 0} {
  171.     eval AlertBoxInternal "\{$alertBoxMessage\}" "\{$alertBoxCommand\}" "\{$alertBoxGeometry\}" "\{$alertBoxTitle\}" $args
  172.   } {
  173.     AlertBoxInternal $alertBoxMessage $alertBoxCommand $alertBoxGeometry $alertBoxTitle
  174.   }
  175.  
  176.   if {[llength $args] > 0} {
  177.     # wait for the box to be destroyed
  178.     update idletask
  179.     grab $alertBox(toplevelName)
  180.     tkwait window $alertBox(toplevelName)
  181.  
  182.     return $alertBox(button)
  183.   }
  184. }
  185.  
  186.  
  187. # Procedure: AlertBoxInternal
  188. proc AlertBoxInternal { alertBoxMessage alertBoxCommand alertBoxGeometry alertBoxTitle args} {
  189. # xf ignore me 6
  190.   global alertBox
  191.  
  192.   set tmpButtonOpt ""
  193.   set tmpFrameOpt ""
  194.   set tmpMessageOpt ""
  195.   if {"$alertBox(activeBackground)" != ""} {
  196.     append tmpButtonOpt "-activebackground \"$alertBox(activeBackground)\" "
  197.   }
  198.   if {"$alertBox(activeForeground)" != ""} {
  199.     append tmpButtonOpt "-activeforeground \"$alertBox(activeForeground)\" "
  200.   }
  201.   if {"$alertBox(background)" != ""} {
  202.     append tmpButtonOpt "-background \"$alertBox(background)\" "
  203.     append tmpFrameOpt "-background \"$alertBox(background)\" "
  204.     append tmpMessageOpt "-background \"$alertBox(background)\" "
  205.   }
  206.   if {"$alertBox(font)" != ""} {
  207.     append tmpButtonOpt "-font \"$alertBox(font)\" "
  208.     append tmpMessageOpt "-font \"$alertBox(font)\" "
  209.   }
  210.   if {"$alertBox(foreground)" != ""} {
  211.     append tmpButtonOpt "-foreground \"$alertBox(foreground)\" "
  212.     append tmpMessageOpt "-foreground \"$alertBox(foreground)\" "
  213.   }
  214.  
  215.   # start build of toplevel
  216.   if {"[info commands XFDestroy]" != ""} {
  217.     catch {XFDestroy $alertBox(toplevelName)}
  218.   } {
  219.     catch {destroy $alertBox(toplevelName)}
  220.   }
  221.   toplevel $alertBox(toplevelName)  -borderwidth 0
  222.   catch "$alertBox(toplevelName) config $tmpFrameOpt"
  223.   if {[catch "wm geometry $alertBox(toplevelName) $alertBoxGeometry"]} {
  224.     wm geometry $alertBox(toplevelName) 350x150
  225.   }
  226.   wm title $alertBox(toplevelName) $alertBoxTitle
  227.   wm maxsize $alertBox(toplevelName) 1000 1000
  228.   wm minsize $alertBox(toplevelName) 100 100
  229.   # end build of toplevel
  230.  
  231.   message $alertBox(toplevelName).message1  -anchor "$alertBox(anchor)"  -justify "$alertBox(justify)"  -relief raised  -text "$alertBoxMessage"
  232.   catch "$alertBox(toplevelName).message1 config $tmpMessageOpt"
  233.  
  234.   set xfTmpWidth  [string range $alertBoxGeometry 0 [expr [string first x $alertBoxGeometry]-1]]
  235.   if {"$xfTmpWidth" != ""} {
  236.     # set message size
  237.     catch "$alertBox(toplevelName).message1 configure  -width [expr $xfTmpWidth-10]"
  238.   } {
  239.     $alertBox(toplevelName).message1 configure  -aspect 1500
  240.   }
  241.  
  242.   frame $alertBox(toplevelName).frame1  -borderwidth 0  -relief raised
  243.   catch "$alertBox(toplevelName).frame1 config $tmpFrameOpt"
  244.  
  245.   set alertBoxCounter 0
  246.   set buttonNum [llength $args]
  247.   if {$buttonNum > 0} {
  248.     while {$alertBoxCounter < $buttonNum} {
  249.       button $alertBox(toplevelName).frame1.button$alertBoxCounter  -text "[lindex $args $alertBoxCounter]"  -command "
  250.           global alertBox
  251.           set alertBox(button) $alertBoxCounter
  252.           if {\"\[info commands XFDestroy\]\" != \"\"} {
  253.             catch {XFDestroy $alertBox(toplevelName)}
  254.           } {
  255.             catch {destroy $alertBox(toplevelName)}
  256.           }"
  257.       catch "$alertBox(toplevelName).frame1.button$alertBoxCounter config $tmpButtonOpt"
  258.  
  259.       pack append $alertBox(toplevelName).frame1  $alertBox(toplevelName).frame1.button$alertBoxCounter {left fillx expand}
  260.  
  261.       incr alertBoxCounter
  262.     }
  263.   } {
  264.     button $alertBox(toplevelName).frame1.button0  -text "OK"  -command "
  265.         global alertBox
  266.         set alertBox(button) 0
  267.         if {\"\[info commands XFDestroy\]\" != \"\"} {
  268.           catch {XFDestroy $alertBox(toplevelName)}
  269.         } {
  270.           catch {destroy $alertBox(toplevelName)}
  271.         }
  272.         $alertBoxCommand"
  273.     catch "$alertBox(toplevelName).frame1.button0 config $tmpButtonOpt"
  274.  
  275.     pack append $alertBox(toplevelName).frame1  $alertBox(toplevelName).frame1.button0 {left fillx expand}
  276.   }
  277.  
  278.   # packing
  279.   pack append $alertBox(toplevelName)  $alertBox(toplevelName).frame1 {bottom fill}  $alertBox(toplevelName).message1 {top fill expand}
  280.  
  281.   if {$alertBox(after) != 0} {
  282.     after [expr $alertBox(after)*1000]  "catch \"$alertBox(toplevelName).frame1.button0 invoke\""
  283.   }
  284. }
  285.  
  286.  
  287. # Procedure: FSBox
  288. proc FSBox { {fsBoxMessage "Select file:"} {fsBoxFileName ""} {fsBoxActionOk ""} {fsBoxActionCancel ""}} {
  289. # xf ignore me 5
  290. ##########
  291. # Procedure: FSBox
  292. # Description: show file selector box
  293. # Arguments: fsBoxMessage - the text to display
  294. #            fsBoxFileName - a file name that should be selected
  295. #            fsBoxActionOk - the action that should be performed on ok
  296. #            fsBoxActionCancel - the action that should be performed on cancel
  297. # Returns: the filename that was selected, or nothing
  298. # Sideeffects: none
  299. ##########
  300. # 
  301. # global fsBox(activeBackground) - active background color
  302. # global fsBox(activeForeground) - active foreground color
  303. # global fsBox(background) - background color
  304. # global fsBox(font) - text font
  305. # global fsBox(foreground) - foreground color
  306. # global fsBox(extensions) - scan directory for extensions
  307. # global fsBox(scrollActiveForeground) - scrollbar active background color
  308. # global fsBox(scrollBackground) - scrollbar background color
  309. # global fsBox(scrollForeground) - scrollbar foreground color
  310. # global fsBox(scrollSide) - side where scrollbar is located
  311.  
  312.   global fsBox
  313.  
  314.   set tmpButtonOpt ""
  315.   set tmpFrameOpt ""
  316.   set tmpMessageOpt ""
  317.   set tmpScaleOpt ""
  318.   set tmpScrollOpt ""
  319.   if {"$fsBox(activeBackground)" != ""} {
  320.     append tmpButtonOpt "-activebackground \"$fsBox(activeBackground)\" "
  321.   }
  322.   if {"$fsBox(activeForeground)" != ""} {
  323.     append tmpButtonOpt "-activeforeground \"$fsBox(activeForeground)\" "
  324.   }
  325.   if {"$fsBox(background)" != ""} {
  326.     append tmpButtonOpt "-background \"$fsBox(background)\" "
  327.     append tmpFrameOpt "-background \"$fsBox(background)\" "
  328.     append tmpMessageOpt "-background \"$fsBox(background)\" "
  329.   }
  330.   if {"$fsBox(font)" != ""} {
  331.     append tmpButtonOpt "-font \"$fsBox(font)\" "
  332.     append tmpMessageOpt "-font \"$fsBox(font)\" "
  333.   }
  334.   if {"$fsBox(foreground)" != ""} {
  335.     append tmpButtonOpt "-foreground \"$fsBox(foreground)\" "
  336.     append tmpMessageOpt "-foreground \"$fsBox(foreground)\" "
  337.   }
  338.   if {"$fsBox(scrollActiveForeground)" != ""} {
  339.     append tmpScrollOpt "-activeforeground \"$fsBox(scrollActiveForeground)\" "
  340.   }
  341.   if {"$fsBox(scrollBackground)" != ""} {
  342.     append tmpScrollOpt "-background \"$fsBox(scrollBackground)\" "
  343.   }
  344.   if {"$fsBox(scrollForeground)" != ""} {
  345.     append tmpScrollOpt "-foreground \"$fsBox(scrollForeground)\" "
  346.   }
  347.  
  348.   if {[file exists [file tail $fsBoxFileName]] &&
  349.       [IsAFile [file tail $fsBoxFileName]]} {
  350.     set fsBox(name) [file tail $fsBoxFileName]
  351.   } {
  352.     set fsBox(name) ""
  353.   }
  354.   if {[file exists $fsBoxFileName] && [IsADir $fsBoxFileName]} {
  355.     set fsBox(path) $fsBoxFileName
  356.   } {
  357.     if {"[file rootname $fsBoxFileName]" != "."} {
  358.       set fsBox(path) [file rootname $fsBoxFileName]
  359.     }
  360.   }
  361.   if {$fsBox(showPixmap)} {
  362.     set fsBox(path) [string trimleft $fsBox(path) @]
  363.   }
  364.   if {"$fsBox(path)" != "" && [file exists $fsBox(path)] &&
  365.       [IsADir $fsBox(path)]} {
  366.     set fsBox(internalPath) $fsBox(path)
  367.   } {
  368.     if {"$fsBox(internalPath)" == "" ||
  369.         ![file exists $fsBox(internalPath)]} {
  370.       set fsBox(internalPath) [pwd]
  371.     }
  372.   }
  373.   # build widget structure
  374.  
  375.   # start build of toplevel
  376.   if {"[info commands XFDestroy]" != ""} {
  377.     catch {XFDestroy .fsBox}
  378.   } {
  379.     catch {destroy .fsBox}
  380.   }
  381.   toplevel .fsBox  -borderwidth 0
  382.   catch ".fsBox config $tmpFrameOpt"
  383.   wm geometry .fsBox 350x300 
  384.   wm title .fsBox {File select box}
  385.   wm maxsize .fsBox 1000 1000
  386.   wm minsize .fsBox 100 100
  387.   # end build of toplevel
  388.  
  389.   label .fsBox.message1  -anchor c  -relief raised  -text "$fsBoxMessage"
  390.   catch ".fsBox.message1 config $tmpMessageOpt"
  391.  
  392.   frame .fsBox.frame1  -borderwidth 0  -relief raised
  393.   catch ".fsBox.frame1 config $tmpFrameOpt"
  394.  
  395.   button .fsBox.frame1.ok  -text "OK"  -command "
  396.       global fsBox
  397.       set fsBox(name) \[.fsBox.file.file get\]
  398.       if {$fsBox(showPixmap)} {
  399.         set fsBox(path) @\[.fsBox.path.path get\]
  400.       } {
  401.         set fsBox(path) \[.fsBox.path.path get\]
  402.       }
  403.       set fsBox(internalPath) \[.fsBox.path.path get\]
  404.       $fsBoxActionOk
  405.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  406.         catch {XFDestroy .fsBox}
  407.       } {
  408.         catch {destroy .fsBox}
  409.       }"
  410.   catch ".fsBox.frame1.ok config $tmpButtonOpt"
  411.  
  412.   button .fsBox.frame1.rescan  -text "Rescan"  -command {
  413.       global fsBox
  414.       FSBoxFSShow [.fsBox.path.path get]  [.fsBox.pattern.pattern get] $fsBox(all)}
  415.   catch ".fsBox.frame1.rescan config $tmpButtonOpt"
  416.  
  417.   button .fsBox.frame1.cancel  -text "Cancel"  -command "
  418.       global fsBox
  419.       set fsBox(name) {}
  420.       set fsBox(path) {}
  421.       $fsBoxActionCancel
  422.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  423.         catch {XFDestroy .fsBox}
  424.       } {
  425.         catch {destroy .fsBox}
  426.       }"
  427.   catch ".fsBox.frame1.cancel config $tmpButtonOpt"
  428.  
  429.   if {$fsBox(showPixmap)} {
  430.     frame .fsBox.frame2  -borderwidth 0  -relief raised
  431.     catch ".fsBox.frame2 config $tmpFrameOpt"
  432.  
  433.     scrollbar .fsBox.frame2.scrollbar3  -command {.fsBox.frame2.canvas2 xview}  -orient {horizontal}  -relief {raised}
  434.     catch ".fsBox.frame2.scrollbar3 config $tmpScrollOpt"
  435.  
  436.     scrollbar .fsBox.frame2.scrollbar1  -command {.fsBox.frame2.canvas2 yview}  -relief {raised}
  437.     catch ".fsBox.frame2.scrollbar1 config $tmpScrollOpt"
  438.  
  439.     canvas .fsBox.frame2.canvas2  -confine {true}  -relief {raised}  -scrollregion {0c 0c 20c 20c}  -width {100}  -xscrollcommand {.fsBox.frame2.scrollbar3 set}  -yscrollcommand {.fsBox.frame2.scrollbar1 set}
  440.     catch ".fsBox.frame2.canvas2 config $tmpFrameOpt"
  441.  
  442.     .fsBox.frame2.canvas2 addtag currentBitmap withtag [.fsBox.frame2.canvas2 create bitmap 5 5 -anchor nw]
  443.   }
  444.  
  445.   frame .fsBox.path  -borderwidth 0  -relief raised
  446.   catch ".fsBox.path config $tmpFrameOpt"
  447.  
  448.   frame .fsBox.path.paths  -borderwidth 2  -relief raised
  449.   catch ".fsBox.path.paths config $tmpFrameOpt"
  450.  
  451.   menubutton .fsBox.path.paths.paths  -borderwidth 0  -menu ".fsBox.path.paths.paths.menu"  -relief flat  -text "Pathname:"
  452.   catch ".fsBox.path.paths.paths config $tmpButtonOpt"
  453.  
  454.   menu .fsBox.path.paths.paths.menu
  455.   catch ".fsBox.path.paths.paths.menu config $tmpButtonOpt"
  456.  
  457.   .fsBox.path.paths.paths.menu add command  -label "[string trimright $fsBox(internalPath) {/@}]"  -command "
  458.        global fsBox
  459.        FSBoxFSShow \[.fsBox.path.path get\]  \[.fsBox.pattern.pattern get\] \$fsBox(all)
  460.        .fsBox.path.path delete 0 end
  461.        .fsBox.path.path insert 0 [string trimright $fsBox(internalPath) {/@}]"
  462.  
  463.   entry .fsBox.path.path  -relief raised
  464.   catch ".fsBox.path.path config $tmpMessageOpt"
  465.  
  466.   if {![IsADir $fsBox(internalPath)]} {
  467.     set $fsBox(internalPath) [pwd]
  468.   }
  469.   .fsBox.path.path insert 0 $fsBox(internalPath)
  470.  
  471.   frame .fsBox.pattern  -borderwidth 0  -relief raised
  472.   catch ".fsBox.pattern config $tmpFrameOpt"
  473.  
  474.   frame .fsBox.pattern.patterns  -borderwidth 2  -relief raised
  475.   catch ".fsBox.pattern.patterns config $tmpFrameOpt"
  476.  
  477.   menubutton .fsBox.pattern.patterns.patterns  -borderwidth 0  -menu ".fsBox.pattern.patterns.patterns.menu"  -relief flat  -text "Selection pattern:"
  478.   catch ".fsBox.pattern.patterns.patterns config $tmpButtonOpt"
  479.  
  480.   menu .fsBox.pattern.patterns.patterns.menu
  481.   catch ".fsBox.pattern.patterns.patterns.menu config $tmpButtonOpt"
  482.  
  483.   .fsBox.pattern.patterns.patterns.menu add checkbutton  -label "Scan extensions"  -variable fsBoxExtensions  -command {
  484.       global fsBox
  485.       FSBoxFSShow [.fsBox.path.path get]  [.fsBox.pattern.pattern get] $fsBox(all)}
  486.  
  487.   entry .fsBox.pattern.pattern  -relief raised
  488.   catch ".fsBox.pattern.pattern config $tmpMessageOpt"
  489.  
  490.   .fsBox.pattern.pattern insert 0 $fsBox(pattern)
  491.   
  492.   frame .fsBox.files  -borderwidth 0  -relief raised
  493.   catch ".fsBox.files config $tmpFrameOpt"
  494.  
  495.   scrollbar .fsBox.files.vscroll  -relief raised  -command ".fsBox.files.files yview"
  496.   catch ".fsBox.files.vscroll config $tmpScrollOpt"
  497.  
  498.   scrollbar .fsBox.files.hscroll  -orient horiz  -relief raised  -command ".fsBox.files.files xview"
  499.   catch ".fsBox.files.hscroll config $tmpScrollOpt"
  500.  
  501.   listbox .fsBox.files.files  -exportselection false  -relief raised  -xscrollcommand ".fsBox.files.hscroll set"  -yscrollcommand ".fsBox.files.vscroll set"
  502.   catch ".fsBox.files.files config $tmpMessageOpt"
  503.  
  504.   frame .fsBox.file  -borderwidth 0  -relief raised
  505.   catch ".fsBox.file config $tmpFrameOpt"
  506.  
  507.   label .fsBox.file.labelfile  -relief raised  -text "Filename:"
  508.   catch ".fsBox.file.labelfile config $tmpMessageOpt"
  509.  
  510.   entry .fsBox.file.file  -relief raised
  511.   catch ".fsBox.file.file config $tmpMessageOpt"
  512.  
  513.   .fsBox.file.file delete 0 end
  514.   .fsBox.file.file insert 0 $fsBox(name)
  515.   
  516.   checkbutton .fsBox.pattern.all  -offvalue 0  -onvalue 1  -text "Show all files"  -variable fsBox(all)  -command {
  517.       global fsBox
  518.       FSBoxFSShow [.fsBox.path.path get]  [.fsBox.pattern.pattern get] $fsBox(all)}
  519.   catch ".fsBox.pattern.all config $tmpButtonOpt"
  520.  
  521.   FSBoxFSShow $fsBox(internalPath) $fsBox(pattern) $fsBox(all)
  522.  
  523.   # bindings
  524.   bind .fsBox.files.files <Double-Button-1> "
  525.     FSBoxFSFileSelectDouble %W $fsBox(showPixmap) \{$fsBoxActionOk\} %y"
  526.   bind .fsBox.files.files <ButtonPress-1> "
  527.     FSBoxFSFileSelect %W $fsBox(showPixmap) %y"
  528.   bind .fsBox.files.files <Button1-Motion> "
  529.     FSBoxFSFileSelect %W $fsBox(showPixmap) %y"
  530.   bind .fsBox.files.files <Shift-Button1-Motion> "
  531.     FSBoxFSFileSelect %W $fsBox(showPixmap) %y"
  532.   bind .fsBox.files.files <Shift-ButtonPress-1> "
  533.     FSBoxFSFileSelect %W $fsBox(showPixmap) %y"
  534.  
  535.   bind .fsBox.path.path <Tab> {
  536.     FSBoxFSNameComplete path}
  537.   bind .fsBox.path.path <Return> {
  538.     global tkVersion
  539.     global fsBox
  540.     FSBoxFSShow [.fsBox.path.path get]  [.fsBox.pattern.pattern get] $fsBox(all)
  541.     FSBoxFSInsertPath
  542.     if {$tkVersion >= 3.0} {
  543.       .fsBox.file.file icursor end
  544.     } {
  545.       .fsBox.file.file cursor end
  546.     }
  547.     focus .fsBox.file.file}
  548.   catch "bind .fsBox.path.path <Up> {}"
  549.   bind .fsBox.path.path <Down> {
  550.     global tkVersion
  551.     if {$tkVersion >= 3.0} {
  552.       .fsBox.file.file icursor end
  553.     } {
  554.       .fsBox.file.file cursor end
  555.     }
  556.     focus .fsBox.file.file}
  557.  
  558.   bind .fsBox.file.file <Tab> {
  559.     FSBoxFSNameComplete file}
  560.   bind .fsBox.file.file <Return> "
  561.     global fsBox
  562.     set fsBox(name) \[.fsBox.file.file get\]
  563.     if {$fsBox(showPixmap)} {
  564.       set fsBox(path) @\[.fsBox.path.path get\]
  565.     } {
  566.       set fsBox(path) \[.fsBox.path.path get\]
  567.     }
  568.     set fsBox(internalPath) \[.fsBox.path.path get\]
  569.     $fsBoxActionOk
  570.     if {\"\[info commands XFDestroy\]\" != \"\"} {
  571.       catch {XFDestroy .fsBox}
  572.     } {
  573.       catch {destroy .fsBox}
  574.     }"
  575.   bind .fsBox.file.file <Up> {
  576.     global tkVersion
  577.     if {$tkVersion >= 3.0} {
  578.       .fsBox.path.path icursor end
  579.     } {
  580.       .fsBox.path.path cursor end
  581.     }
  582.     focus .fsBox.path.path}
  583.   bind .fsBox.file.file <Down> {
  584.     global tkVersion
  585.     if {$tkVersion >= 3.0} {
  586.       .fsBox.pattern.pattern icursor end
  587.     } {
  588.       .fsBox.pattern.pattern cursor end
  589.     }
  590.     focus .fsBox.pattern.pattern}
  591.  
  592.   bind .fsBox.pattern.pattern <Return> {
  593.     global fsBox
  594.     FSBoxFSShow [.fsBox.path.path get]  [.fsBox.pattern.pattern get] $fsBox(all)}
  595.   bind .fsBox.pattern.pattern <Up> {
  596.     global tkVersion
  597.     if {$tkVersion >= 3.0} {
  598.       .fsBox.file.file icursor end
  599.     } {
  600.       .fsBox.file.file cursor end
  601.     }
  602.     focus .fsBox.file.file}
  603.   catch "bind .fsBox.pattern.pattern <Down> {}"
  604.  
  605.   # packing
  606.   pack append .fsBox.files  .fsBox.files.vscroll "$fsBox(scrollSide) filly"  .fsBox.files.hscroll {bottom fillx}  .fsBox.files.files {left fill expand}
  607.   pack append .fsBox.file  .fsBox.file.labelfile {left}  .fsBox.file.file {left fill expand}
  608.   pack append .fsBox.frame1  .fsBox.frame1.ok {left fill expand}  .fsBox.frame1.rescan {left fill expand}  .fsBox.frame1.cancel {left fill expand}
  609.   pack append .fsBox.path.paths  .fsBox.path.paths.paths {left}
  610.   pack append .fsBox.pattern.patterns  .fsBox.pattern.patterns.patterns {left}
  611.   pack append .fsBox.path  .fsBox.path.paths {left}  .fsBox.path.path {left fill expand}
  612.   pack append .fsBox.pattern  .fsBox.pattern.patterns {left}  .fsBox.pattern.all {right fill}  .fsBox.pattern.pattern {left fill expand}
  613.   if {$fsBox(showPixmap)} {
  614.     pack append .fsBox.frame2  .fsBox.frame2.scrollbar1 {left filly}  .fsBox.frame2.canvas2 {top expand fill}  .fsBox.frame2.scrollbar3 {top fillx} 
  615.  
  616.     pack append .fsBox  .fsBox.message1 {top fill}  .fsBox.frame1 {bottom fill}  .fsBox.pattern {bottom fill}  .fsBox.file {bottom fill}  .fsBox.path {bottom fill}  .fsBox.frame2 {right fill}  .fsBox.files {left fill expand}
  617.   } {
  618.     pack append .fsBox  .fsBox.message1 {top fill}  .fsBox.frame1 {bottom fill}  .fsBox.pattern {bottom fill}  .fsBox.file {bottom fill}  .fsBox.path {bottom fill}  .fsBox.files {left fill expand}
  619.   }
  620.  
  621.   if {"$fsBoxActionOk" == "" && "$fsBoxActionCancel" == ""} {
  622.     # wait for the box to be destroyed
  623.     update idletask
  624.     grab .fsBox
  625.     tkwait window .fsBox
  626.  
  627.     if {"[string trim $fsBox(path)]" != "" ||
  628.         "[string trim $fsBox(name)]" != ""} {
  629.       if {"[string trimleft [string trim $fsBox(name)] /]" == ""} {
  630.         return [string trimright [string trim $fsBox(path)] /]
  631.       } {
  632.         return [string trimright [string trim $fsBox(path)] /]/[string trimleft [string trim $fsBox(name)] /]
  633.       }
  634.     }
  635.   }
  636. }
  637.  
  638.  
  639. # Procedure: FSBoxBindSelectOne
  640. proc FSBoxBindSelectOne { fsBoxW fsBoxY} {
  641. # xf ignore me 6
  642.  
  643.   set fsBoxNearest [$fsBoxW nearest $fsBoxY]
  644.   if {$fsBoxNearest >= 0} {
  645.     $fsBoxW select from $fsBoxNearest
  646.     $fsBoxW select to $fsBoxNearest
  647.   }
  648. }
  649.  
  650.  
  651. # Procedure: FSBoxFSFileSelect
  652. proc FSBoxFSFileSelect { fsBoxW fsBoxShowPixmap fsBoxY} {
  653. # xf ignore me 6
  654.   global fsBox
  655.  
  656.   FSBoxBindSelectOne $fsBoxW $fsBoxY
  657.   set fsBoxNearest [$fsBoxW nearest $fsBoxY]
  658.   if {$fsBoxNearest >= 0} {
  659.     set fsBoxTmpEntry [$fsBoxW get $fsBoxNearest]
  660.     if {"[string index $fsBoxTmpEntry  [expr [string length $fsBoxTmpEntry]-1]]" == "/" ||
  661.         "[string index $fsBoxTmpEntry  [expr [string length $fsBoxTmpEntry]-1]]" == "@"} {
  662.       set fsBoxFileName [string range $fsBoxTmpEntry 0  [expr [string length $fsBoxTmpEntry]-2]]
  663.       if {![IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]] &&
  664.           ![IsASymlink [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} {
  665.         set fsBoxFileName $fsBoxTmpEntry
  666.       }
  667.     } {
  668.       if {"[string index $fsBoxTmpEntry  [expr [string length $fsBoxTmpEntry]-1]]" == "*"} {
  669.         set fsBoxFileName [string range $fsBoxTmpEntry 0  [expr [string length $fsBoxTmpEntry]-2]]
  670.         if {![file executable $fsBox(internalPath)/$fsBoxFileName]} {
  671.           set fsBoxFileName $fsBoxTmpEntry
  672.         }
  673.       } {
  674.         set fsBoxFileName $fsBoxTmpEntry
  675.       }
  676.     }
  677.     if {![IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} {
  678.       set fsBox(name) $fsBoxFileName
  679.       .fsBox.file.file delete 0 end
  680.       .fsBox.file.file insert 0 $fsBox(name)
  681.       if {$fsBoxShowPixmap} {
  682.         catch ".fsBox.frame2.canvas2 itemconfigure currentBitmap -bitmap \"@$fsBox(internalPath)/$fsBox(name)\""
  683.       }
  684.     }
  685.   }
  686. }
  687.  
  688.  
  689. # Procedure: FSBoxFSFileSelectDouble
  690. proc FSBoxFSFileSelectDouble { fsBoxW fsBoxShowPixmap fsBoxAction fsBoxY} {
  691. # xf ignore me 6
  692.   global fsBox
  693.  
  694.   FSBoxBindSelectOne $fsBoxW $fsBoxY
  695.   set fsBoxNearest [$fsBoxW nearest $fsBoxY]
  696.   if {$fsBoxNearest >= 0} {
  697.     set fsBoxTmpEntry [$fsBoxW get $fsBoxNearest]
  698.     if {"$fsBoxTmpEntry" == "../"} {
  699.       set fsBoxTmpEntry [string trimright [string trim $fsBox(internalPath)] "@/"]
  700.       if {"$fsBoxTmpEntry" == ""} {
  701.         return
  702.       }
  703.       FSBoxFSShow [file dirname $fsBoxTmpEntry]  [.fsBox.pattern.pattern get] $fsBox(all)
  704.       .fsBox.path.path delete 0 end
  705.       .fsBox.path.path insert 0 $fsBox(internalPath)
  706.     } {
  707.       if {"[string index $fsBoxTmpEntry  [expr [string length $fsBoxTmpEntry]-1]]" == "/" ||
  708.           "[string index $fsBoxTmpEntry  [expr [string length $fsBoxTmpEntry]-1]]" == "@"} {
  709.         set fsBoxFileName [string range $fsBoxTmpEntry 0  [expr [string length $fsBoxTmpEntry]-2]]
  710.         if {![IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]] &&
  711.             ![IsASymlink [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} {
  712.           set fsBoxFileName $fsBoxTmpEntry
  713.         }
  714.       } {
  715.         if {"[string index $fsBoxTmpEntry  [expr [string length $fsBoxTmpEntry]-1]]" == "*"} {
  716.           set fsBoxFileName [string range $fsBoxTmpEntry 0  [expr [string length $fsBoxTmpEntry]-2]]
  717.           if {![file executable $fsBox(internalPath)/$fsBoxFileName]} {
  718.             set fsBoxFileName $fsBoxTmpEntry
  719.           }
  720.         } {
  721.           set fsBoxFileName $fsBoxTmpEntry
  722.         }
  723.       }
  724.       if {[IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} {
  725.         set fsBox(internalPath) "[string trimright $fsBox(internalPath) {/@}]/$fsBoxFileName"
  726.         FSBoxFSShow $fsBox(internalPath)  [.fsBox.pattern.pattern get] $fsBox(all)
  727.         .fsBox.path.path delete 0 end
  728.         .fsBox.path.path insert 0 $fsBox(internalPath)
  729.       } {
  730.         set fsBox(name) $fsBoxFileName
  731.         if {$fsBoxShowPixmap} {
  732.           set fsBox(path) @$fsBox(internalPath)
  733.         } {
  734.           set fsBox(path) $fsBox(internalPath)
  735.         }
  736.         if {"$fsBoxAction" != ""} {
  737.           eval "global fsBox; $fsBoxAction"
  738.         }
  739.         if {"[info commands XFDestroy]" != ""} {
  740.           catch {XFDestroy .fsBox}
  741.         } {
  742.           catch {destroy .fsBox}
  743.         }
  744.       }
  745.     }
  746.   }
  747. }
  748.  
  749.  
  750. # Procedure: FSBoxFSInsertPath
  751. proc FSBoxFSInsertPath {} {
  752. # xf ignore me 6
  753.   global fsBox
  754.  
  755.   set fsBoxLast [.fsBox.path.paths.paths.menu index last]
  756.   set fsBoxNewEntry [string trimright [.fsBox.path.path get] "/@"]
  757.   for {set fsBoxCounter 0} {$fsBoxCounter <= $fsBoxLast} {incr fsBoxCounter 1} {
  758.     if {"$fsBoxNewEntry" ==  "[lindex [.fsBox.path.paths.paths.menu entryconfigure  $fsBoxCounter -label] 4]"} {
  759.       return
  760.     }
  761.   }
  762.   if {$fsBoxLast < 9} {
  763.     .fsBox.path.paths.paths.menu add command  -label "$fsBoxNewEntry"  -command "
  764.         global fsBox
  765.         FSBoxFSShow $fsBoxNewEntry  \[.fsBox.pattern.pattern get\] \$fsBox(all)
  766.         .fsBox.path.path delete 0 end
  767.         .fsBox.path.path insert 0 $fsBoxNewEntry"
  768.   } {
  769.     for {set fsBoxCounter 0} {$fsBoxCounter < $fsBoxLast} {incr fsBoxCounter 1} {
  770.       .fsBox.path.paths.paths.menu entryconfigure  $fsBoxCounter -label  [lindex [.fsBox.path.paths.paths.menu entryconfigure  [expr $fsBoxCounter+1] -label] 4]
  771.       .fsBox.path.paths.paths.menu entryconfigure $fsBoxCounter  -command "
  772.           global fsBox
  773.           FSBoxFSShow [lindex [.fsBox.path.paths.paths.menu entryconfigure  [expr $fsBoxCounter+1] -label] 4]  \[.fsBox.pattern.pattern get\] \$fsBox(all)
  774.           .fsBox.path.path delete 0 end
  775.           .fsBox.path.path insert 0 [lindex  [.fsBox.path.paths.paths.menu entryconfigure  [expr $fsBoxCounter+1] -label] 4]"
  776.     }
  777.     .fsBox.path.paths.paths.menu entryconfigure $fsBoxLast  -label "$fsBoxNewEntry"
  778.     .fsBox.path.paths.paths.menu entryconfigure $fsBoxCounter  -command "
  779.         global fsBox
  780.         FSBoxFSShow \[.fsBox.path.path get\]  \[.fsBox.pattern.pattern get\] \$fsBox(all)
  781.         .fsBox.path.path delete 0 end
  782.         .fsBox.path.path insert 0 $fsBoxNewEntry"
  783.   }
  784. }
  785.  
  786.  
  787. # Procedure: FSBoxFSNameComplete
  788. proc FSBoxFSNameComplete { fsBoxType} {
  789. # xf ignore me 6
  790.   global tkVersion
  791.   global fsBox
  792.  
  793.   set fsBoxNewFile ""
  794.   if {"$fsBoxType" == "path"} {
  795.     set fsBoxDirName [file dirname [.fsBox.path.path get]]
  796.     set fsBoxFileName [file tail [.fsBox.path.path get]]
  797.   } {
  798.     set fsBoxDirName [file dirname [.fsBox.path.path get]/]
  799.     set fsBoxFileName [file tail [.fsBox.file.file get]]
  800.   }
  801.  
  802.   set fsBoxNewFile ""
  803.   if {[IsADir [string trimright $fsBoxDirName @]]} {
  804.     catch "glob -nocomplain $fsBoxDirName/${fsBoxFileName}*" fsBoxResult
  805.     foreach fsBoxCounter $fsBoxResult {
  806.       if {"$fsBoxNewFile" == ""} {
  807.         set fsBoxNewFile [file tail $fsBoxCounter]
  808.       } {
  809.         if {"[string index [file tail $fsBoxCounter] 0]" !=
  810.             "[string index $fsBoxNewFile 0]"} {
  811.           set fsBoxNewFile ""
  812.           break
  813.         }
  814.         set fsBoxCounter1 0
  815.         set fsBoxTmpFile1 $fsBoxNewFile
  816.         set fsBoxTmpFile2 [file tail $fsBoxCounter]
  817.         set fsBoxLength1 [string length $fsBoxTmpFile1]
  818.         set fsBoxLength2 [string length $fsBoxTmpFile2]
  819.         set fsBoxNewFile ""
  820.         if {$fsBoxLength1 > $fsBoxLength2} {
  821.           set fsBoxLength1 $fsBoxLength2
  822.         }
  823.         while {$fsBoxCounter1 < $fsBoxLength1} {
  824.           if {"[string index $fsBoxTmpFile1 $fsBoxCounter1]" ==  "[string index $fsBoxTmpFile2 $fsBoxCounter1]"} {
  825.             append fsBoxNewFile [string index $fsBoxTmpFile1 $fsBoxCounter1]
  826.           } {
  827.             break
  828.           }
  829.           incr fsBoxCounter1 1
  830.         }
  831.       }
  832.     }
  833.   }
  834.   if {"$fsBoxNewFile" != ""} {
  835.     if {[IsADir [string trimright $fsBoxDirName/$fsBoxNewFile @]] ||
  836.         ![IsAFile [string trimright $fsBoxDirName/$fsBoxNewFile @]]} {
  837.       if {[IsADir [string trimright $fsBoxDirName/$fsBoxNewFile @]]} {
  838.         if {"$fsBoxDirName" == "/"} {
  839.           .fsBox.path.path delete 0 end
  840.           .fsBox.path.path insert 0 "/[string trimright [string trim $fsBoxNewFile /] @]/"
  841.         } {
  842.           .fsBox.path.path delete 0 end
  843.           .fsBox.path.path insert 0 "[string trimright $fsBoxDirName /]/[string trimright [string trim $fsBoxNewFile /] @]/"
  844.         }
  845.         FSBoxFSShow [.fsBox.path.path get]  [.fsBox.pattern.pattern get] $fsBox(all)
  846.         FSBoxFSInsertPath
  847.       } {
  848.         .fsBox.path.path delete 0 end
  849.         .fsBox.path.path insert 0 "[string trimright $fsBoxDirName /]/[string trimright [string trim $fsBoxNewFile /] @]"
  850.       }
  851.     } {
  852.       .fsBox.path.path delete 0 end
  853.       .fsBox.path.path insert 0 "[string trimright $fsBoxDirName {@/}]/"
  854.       .fsBox.file.file delete 0 end
  855.       .fsBox.file.file insert 0 $fsBoxNewFile
  856.       if {$tkVersion >= 3.0} {
  857.         .fsBox.file.file icursor end
  858.       } {
  859.         .fsBox.file.file cursor end
  860.       }
  861.       focus .fsBox.file.file
  862.     }
  863.   }
  864. }
  865.  
  866.  
  867. # Procedure: FSBoxFSShow
  868. proc FSBoxFSShow { fsBoxPath fsBoxPattern fsBoxAll} {
  869. # xf ignore me 6
  870.   global fsBox
  871.  
  872.   set tmpButtonOpt ""
  873.   if {"$fsBox(activeBackground)" != ""} {
  874.     append tmpButtonOpt "-activebackground \"$fsBox(activeBackground)\" "
  875.   }
  876.   if {"$fsBox(activeForeground)" != ""} {
  877.     append tmpButtonOpt "-activeforeground \"$fsBox(activeForeground)\" "
  878.   }
  879.   if {"$fsBox(background)" != ""} {
  880.     append tmpButtonOpt "-background \"$fsBox(background)\" "
  881.   }
  882.   if {"$fsBox(font)" != ""} {
  883.     append tmpButtonOpt "-font \"$fsBox(font)\" "
  884.   }
  885.   if {"$fsBox(foreground)" != ""} {
  886.     append tmpButtonOpt "-foreground \"$fsBox(foreground)\" "
  887.   }
  888.  
  889.   set fsBox(pattern) $fsBoxPattern
  890.   if {[file exists $fsBoxPath] && [file readable $fsBoxPath] &&
  891.       [IsADir $fsBoxPath]} {
  892.     set fsBox(internalPath) $fsBoxPath
  893.   } {
  894.     if {[file exists $fsBoxPath] && [file readable $fsBoxPath] &&
  895.         [IsAFile $fsBoxPath]} {
  896.       set fsBox(internalPath) [file dirname $fsBoxPath]
  897.       .fsBox.file.file delete 0 end
  898.       .fsBox.file.file insert 0 [file tail $fsBoxPath]
  899.       set fsBoxPath $fsBox(internalPath)
  900.     } {
  901.       while {"$fsBoxPath" != "" && "$fsBoxPath" != "/" &&
  902.              ![file isdirectory $fsBoxPath]} {
  903.         set fsBox(internalPath) [file dirname $fsBoxPath]
  904.          set fsBoxPath $fsBox(internalPath)
  905.       }
  906.     }
  907.   }
  908.   if {"$fsBoxPath" == ""} {
  909.     set fsBoxPath "/"
  910.     set fsBox(internalPath) "/"
  911.   }
  912.   .fsBox.path.path delete 0 end
  913.   .fsBox.path.path insert 0 $fsBox(internalPath)
  914.  
  915.   if {[.fsBox.files.files size] > 0} {
  916.     .fsBox.files.files delete 0 end
  917.   }
  918.   if {$fsBoxAll} {
  919.     if {[catch "exec ls -F -a $fsBoxPath" fsBoxResult]} {
  920.       puts stderr "$fsBoxResult"
  921.     }
  922.   } {
  923.     if {[catch "exec ls -F $fsBoxPath" fsBoxResult]} {
  924.       puts stderr "$fsBoxResult"
  925.     }
  926.   }
  927.   set fsBoxElementList [lsort $fsBoxResult]
  928.  
  929.   foreach fsBoxCounter [winfo children .fsBox.pattern.patterns.patterns] {
  930.     if {[string length [info commands XFDestroy]] > 0} {
  931.       catch {XFDestroy $fsBoxCounter}
  932.     } {
  933.       catch {destroy $fsBoxCounter}
  934.     }
  935.   }
  936.   menu .fsBox.pattern.patterns.patterns.menu
  937.   catch ".fsBox.pattern.patterns.patterns.menu config $tmpButtonOpt"
  938.  
  939.   if {$fsBox(extensions)} {
  940.     .fsBox.pattern.patterns.patterns.menu add command  -label "*"  -command {
  941.         global fsBox
  942.         set fsBox(pattern) "*"
  943.         .fsBox.pattern.pattern delete 0 end
  944.         .fsBox.pattern.pattern insert 0 $fsBox(pattern)
  945.         FSBoxFSShow [.fsBox.path.path get] $fsBox(pattern)  $fsBox(all)}
  946.   }
  947.  
  948.   if {"$fsBoxPath" != "/"} {
  949.     .fsBox.files.files insert end "../"
  950.   }
  951.   foreach fsBoxCounter $fsBoxElementList {
  952.     if {[string match $fsBoxPattern $fsBoxCounter] ||
  953.         [IsADir [string trimright $fsBoxPath/$fsBoxCounter "/@"]]} {
  954.       if {"$fsBoxCounter" != "../" &&
  955.           "$fsBoxCounter" != "./"} {
  956.         .fsBox.files.files insert end $fsBoxCounter
  957.       }
  958.     }
  959.  
  960.     if {$fsBox(extensions)} {
  961.       catch "file rootname $fsBoxCounter" fsBoxRootName
  962.       catch "file extension $fsBoxCounter" fsBoxExtension
  963.       set fsBoxExtension [string trimright $fsBoxExtension "/*@"]
  964.       if {"$fsBoxExtension" != "" && "$fsBoxRootName" != ""} {
  965.         set fsBoxInsert 1
  966.         set fsBoxLast [.fsBox.pattern.patterns.patterns.menu index last]
  967.         for {set fsBoxCounter1 0} {$fsBoxCounter1 <= $fsBoxLast} {incr fsBoxCounter1 1} {
  968.           if {"*$fsBoxExtension" ==  "[lindex [.fsBox.pattern.patterns.patterns.menu entryconfigure  $fsBoxCounter1 -label] 4]"} {
  969.             set fsBoxInsert 0
  970.           }
  971.         }
  972.     if {$fsBoxInsert} {
  973.           .fsBox.pattern.patterns.patterns.menu add command  -label "*$fsBoxExtension"  -command "
  974.               global fsBox
  975.               set fsBox(pattern) \"*$fsBoxExtension\"
  976.               .fsBox.pattern.pattern delete 0 end
  977.               .fsBox.pattern.pattern insert 0 \$fsBox(pattern)
  978.               FSBoxFSShow \[.fsBox.path.path get\] \$fsBox(pattern)  \$fsBox(all)"
  979.         }
  980.       }
  981.     }
  982.   }
  983.   if {$fsBox(extensions)} {
  984.     .fsBox.pattern.patterns.patterns.menu add separator
  985.   }
  986.   if {$fsBox(extensions) || 
  987.       "[.fsBox.pattern.patterns.patterns.menu index last]" == "none"} {
  988.     .fsBox.pattern.patterns.patterns.menu add checkbutton  -label "Scan extensions"  -variable "fsBox(extensions)"  -command {
  989.         global fsBox
  990.         FSBoxFSShow [.fsBox.path.path get]  [.fsBox.pattern.pattern get] $fsBox(all)}
  991.   }
  992. }
  993.  
  994.  
  995. # Procedure: HistoryTextBox
  996. proc HistoryTextBox {} {
  997.   global ModificationHistory
  998.   TextBox [format "Role Playing DataBase system Modification history\n%s"  $ModificationHistory] "" 600x300 "History Box"
  999. }
  1000.  
  1001.  
  1002. # Procedure: InputBoxInternal
  1003. proc InputBoxInternal { inputBoxMessage inputBoxCommandOk inputBoxCommandCancel inputBoxGeometry inputBoxTitle lineNum} {
  1004. # xf ignore me 6
  1005.   global inputBox
  1006.  
  1007.   set tmpButtonOpt ""
  1008.   set tmpFrameOpt ""
  1009.   set tmpMessageOpt ""
  1010.   set tmpScaleOpt ""
  1011.   set tmpScrollOpt ""
  1012.   if {"$inputBox(activeBackground)" != ""} {
  1013.     append tmpButtonOpt "-activebackground \"$inputBox(activeBackground)\" "
  1014.   }
  1015.   if {"$inputBox(activeForeground)" != ""} {
  1016.     append tmpButtonOpt "-activeforeground \"$inputBox(activeForeground)\" "
  1017.   }
  1018.   if {"$inputBox(background)" != ""} {
  1019.     append tmpButtonOpt "-background \"$inputBox(background)\" "
  1020.     append tmpFrameOpt "-background \"$inputBox(background)\" "
  1021.     append tmpMessageOpt "-background \"$inputBox(background)\" "
  1022.   }
  1023.   if {"$inputBox(font)" != ""} {
  1024.     append tmpButtonOpt "-font \"$inputBox(font)\" "
  1025.     append tmpMessageOpt "-font \"$inputBox(font)\" "
  1026.   }
  1027.   if {"$inputBox(foreground)" != ""} {
  1028.     append tmpButtonOpt "-foreground \"$inputBox(foreground)\" "
  1029.     append tmpMessageOpt "-foreground \"$inputBox(foreground)\" "
  1030.   }
  1031.   if {"$inputBox(scrollActiveForeground)" != ""} {
  1032.     append tmpScrollOpt "-activeforeground \"$inputBox(scrollActiveForeground)\" "
  1033.   }
  1034.   if {"$inputBox(scrollBackground)" != ""} {
  1035.     append tmpScrollOpt "-background \"$inputBox(scrollBackground)\" "
  1036.   }
  1037.   if {"$inputBox(scrollForeground)" != ""} {
  1038.     append tmpScrollOpt "-foreground \"$inputBox(scrollForeground)\" "
  1039.   }
  1040.  
  1041.   # start build of toplevel
  1042.   if {"[info commands XFDestroy]" != ""} {
  1043.     catch {XFDestroy $inputBox(toplevelName)}
  1044.   } {
  1045.     catch {destroy $inputBox(toplevelName)}
  1046.   }
  1047.   toplevel $inputBox(toplevelName)  -borderwidth 0
  1048.   catch "$inputBox(toplevelName) config $tmpFrameOpt"
  1049.   if {[catch "wm geometry $inputBox(toplevelName) $inputBoxGeometry"]} {
  1050.     wm geometry $inputBox(toplevelName) 350x150
  1051.   }
  1052.   wm title $inputBox(toplevelName) $inputBoxTitle
  1053.   wm maxsize $inputBox(toplevelName) 1000 1000
  1054.   wm minsize $inputBox(toplevelName) 100 100
  1055.   # end build of toplevel
  1056.  
  1057.   message $inputBox(toplevelName).message1  -anchor "$inputBox(anchor)"  -justify "$inputBox(justify)"  -relief raised  -text "$inputBoxMessage"
  1058.   catch "$inputBox(toplevelName).message1 config $tmpMessageOpt"
  1059.  
  1060.   set xfTmpWidth  [string range $inputBoxGeometry 0 [expr [string first x $inputBoxGeometry]-1]]
  1061.   if {"$xfTmpWidth" != ""} {
  1062.     # set message size
  1063.     catch "$inputBox(toplevelName).message1 configure  -width [expr $xfTmpWidth-10]"
  1064.   } {
  1065.     $inputBox(toplevelName).message1 configure  -aspect 1500
  1066.   }
  1067.  
  1068.   frame $inputBox(toplevelName).frame0  -borderwidth 0  -relief raised
  1069.   catch "$inputBox(toplevelName).frame0 config $tmpFrameOpt"
  1070.  
  1071.   frame $inputBox(toplevelName).frame1  -borderwidth 0  -relief raised
  1072.   catch "$inputBox(toplevelName).frame1 config $tmpFrameOpt"
  1073.  
  1074.   if {$lineNum == 1} {
  1075.     scrollbar $inputBox(toplevelName).frame1.hscroll  -orient "horizontal"  -relief raised  -command "$inputBox(toplevelName).frame1.input view"
  1076.     catch "$inputBox(toplevelName).frame1.hscroll config $tmpScrollOpt"
  1077.  
  1078.     entry $inputBox(toplevelName).frame1.input  -relief raised  -scrollcommand "$inputBox(toplevelName).frame1.hscroll set"
  1079.     catch "$inputBox(toplevelName).frame1.input config $tmpMessageOpt"
  1080.  
  1081.     $inputBox(toplevelName).frame1.input insert 0  $inputBox($inputBox(toplevelName),inputOne)
  1082.     
  1083.     # bindings
  1084.     bind $inputBox(toplevelName).frame1.input <Return> "
  1085.       global inputBox
  1086.       set inputBox($inputBox(toplevelName),inputOne) \[$inputBox(toplevelName).frame1.input get\]
  1087.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  1088.         catch {XFDestroy $inputBox(toplevelName)}
  1089.       } {
  1090.         catch {destroy $inputBox(toplevelName)}
  1091.       }
  1092.       $inputBoxCommandOk"
  1093.     
  1094.     # packing
  1095.     pack append $inputBox(toplevelName).frame1  $inputBox(toplevelName).frame1.hscroll {bottom fill}  $inputBox(toplevelName).frame1.input {top fill expand}
  1096.   } {
  1097.     text $inputBox(toplevelName).frame1.input  -relief raised  -wrap none  -borderwidth 2  -yscrollcommand "$inputBox(toplevelName).frame1.vscroll set"
  1098.     catch "$inputBox(toplevelName).frame1.input config $tmpMessageOpt"
  1099.  
  1100.     scrollbar $inputBox(toplevelName).frame1.vscroll  -relief raised  -command "$inputBox(toplevelName).frame1.input yview"
  1101.     catch "$inputBox(toplevelName).frame1.vscroll config $tmpScrollOpt"
  1102.  
  1103.     $inputBox(toplevelName).frame1.input insert 1.0  $inputBox($inputBox(toplevelName),inputMulti)
  1104.  
  1105.     # bindings
  1106.     bind $inputBox(toplevelName).frame1.input <Control-Return> "
  1107.       global inputBox
  1108.       set inputBox($inputBox(toplevelName),inputMulti) \[$inputBox(toplevelName).frame1.input get 1.0 end\]
  1109.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  1110.         catch {XFDestroy $inputBox(toplevelName)}
  1111.       } {
  1112.         catch {destroy $inputBox(toplevelName)}
  1113.       }
  1114.       $inputBoxCommandOk"
  1115.     bind $inputBox(toplevelName).frame1.input <Meta-Return> "
  1116.       global inputBox
  1117.       set inputBox($inputBox(toplevelName),inputMulti) \[$inputBox(toplevelName).frame1.input get 1.0 end\]
  1118.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  1119.         catch {XFDestroy $inputBox(toplevelName)}
  1120.       } {
  1121.         catch {destroy $inputBox(toplevelName)}
  1122.       }
  1123.       $inputBoxCommandOk"
  1124.  
  1125.     # packing
  1126.     pack append $inputBox(toplevelName).frame1  $inputBox(toplevelName).frame1.vscroll "$inputBox(scrollSide) filly"  $inputBox(toplevelName).frame1.input {left fill expand}
  1127.   }
  1128.   
  1129.   button $inputBox(toplevelName).frame0.button0  -text "OK"  -command "
  1130.       global inputBox
  1131.       if {$lineNum == 1} {
  1132.         set inputBox($inputBox(toplevelName),inputOne) \[$inputBox(toplevelName).frame1.input get\]
  1133.       } {
  1134.         set inputBox($inputBox(toplevelName),inputMulti) \[$inputBox(toplevelName).frame1.input get 1.0 end\]
  1135.       }
  1136.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  1137.         catch {XFDestroy $inputBox(toplevelName)}
  1138.       } {
  1139.         catch {destroy $inputBox(toplevelName)}
  1140.       }
  1141.       $inputBoxCommandOk"
  1142.   catch "$inputBox(toplevelName).frame0.button0 config $tmpButtonOpt"
  1143.  
  1144.   button $inputBox(toplevelName).frame0.button1  -text "Cancel"  -command "
  1145.       global inputBox
  1146.       if {$lineNum == 1} {
  1147.         set inputBox($inputBox(toplevelName),inputOne) \"\"
  1148.       } {
  1149.         set inputBox($inputBox(toplevelName),inputMulti) \"\"
  1150.       }
  1151.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  1152.         catch {XFDestroy $inputBox(toplevelName)}
  1153.       } {
  1154.         catch {destroy $inputBox(toplevelName)}
  1155.       }
  1156.       $inputBoxCommandCancel"
  1157.   catch "$inputBox(toplevelName).frame0.button1 config $tmpButtonOpt"
  1158.  
  1159.   pack append $inputBox(toplevelName).frame0  $inputBox(toplevelName).frame0.button0 {left fill expand}  $inputBox(toplevelName).frame0.button1 {left fill expand}
  1160.  
  1161.   pack append $inputBox(toplevelName)  $inputBox(toplevelName).frame0 {bottom fill}  $inputBox(toplevelName).frame1 {bottom fill expand}  $inputBox(toplevelName).message1 {top fill}
  1162. }
  1163.  
  1164.  
  1165. # Procedure: InputBoxMulti
  1166. proc InputBoxMulti { {inputBoxMessage "Input box:"} {inputBoxCommandOk ""} {inputBoxCommandCancel ""} {inputBoxGeometry "350x150"} {inputBoxTitle "Input box"}} {
  1167. # xf ignore me 5
  1168. ##########
  1169. # Procedure: InputBoxMulti
  1170. # Description: show input box with one text line
  1171. # Arguments: {inputBoxMessage} - message to display
  1172. #            {inputBoxCommandOk} - the command to call after ok
  1173. #            {inputBoxCommandCancel} - the command to call after cancel
  1174. #            {inputBoxGeometry} - the geometry for the window
  1175. #            {inputBoxTitle} - the title for the window
  1176. # Returns: The entered text
  1177. # Sideeffects: none
  1178. # Notes: there exist also a function called:
  1179. #          InputBoxOne - to enter one line text
  1180. ##########
  1181. #
  1182. # global inputBox(activeBackground) - active background color
  1183. # global inputBox(activeForeground) - active foreground color
  1184. # global inputBox(anchor) - anchor for message box
  1185. # global inputBox(background) - background color
  1186. # global inputBox(erase) - erase previous text
  1187. # global inputBox(font) - message font
  1188. # global inputBox(foreground) - foreground color
  1189. # global inputBox(justify) - justify for message box
  1190. # global inputBox(scrollActiveForeground) - scrollbar active background color
  1191. # global inputBox(scrollBackground) - scrollbar background color
  1192. # global inputBox(scrollForeground) - scrollbar foreground color
  1193. # global inputBox(scrollSide) - side where scrollbar is located
  1194. # global inputBox(toplevelName) - the toplevel name
  1195. # global inputBox(toplevelName,inputMulti) - the text in the text widget
  1196.  
  1197.   global inputBox
  1198.  
  1199.   if {"$inputBoxGeometry" == ""} {
  1200.     set inputBoxGeometry 350x150
  1201.   }
  1202.   if {$inputBox(erase)} {
  1203.     set inputBox($inputBox(toplevelName),inputMulti) ""
  1204.   } {
  1205.     if {![info exists inputBox($inputBox(toplevelName),inputMulti)]} {
  1206.       set inputBox($inputBox(toplevelName),inputMulti) ""
  1207.     }
  1208.   }
  1209.   InputBoxInternal $inputBoxMessage $inputBoxCommandOk $inputBoxCommandCancel $inputBoxGeometry $inputBoxTitle 2
  1210.  
  1211.   # wait for the box to be destroyed
  1212.   update idletask
  1213.   grab $inputBox(toplevelName)
  1214.   tkwait window $inputBox(toplevelName)
  1215.  
  1216.   return $inputBox($inputBox(toplevelName),inputMulti)
  1217. }
  1218.  
  1219.  
  1220. # Procedure: InputBoxOne
  1221. proc InputBoxOne { {inputBoxMessage "Input box:"} {inputBoxCommandOk ""} {inputBoxCommandCancel ""} {inputBoxGeometry "350x150"} {inputBoxTitle "Input box"}} {
  1222. # xf ignore me 5
  1223. ##########
  1224. # Procedure: InputBoxOne
  1225. # Description: show input box with one text line
  1226. # Arguments: {inputBoxMessage} - message to display
  1227. #            {inputBoxCommandOk} - the command to call after ok
  1228. #            {inputBoxCommandCancel} - the command to call after cancel
  1229. #            {inputBoxGeometry} - the geometry for the window
  1230. #            {inputBoxTitle} - the title for the window
  1231. # Returns: The entered text
  1232. # Sideeffects: none
  1233. # Notes: there exist also a function called:
  1234. #          InputBoxMulti - to enter multiline text
  1235. ##########
  1236. #
  1237. # global inputBox(activeBackground) - active background color
  1238. # global inputBox(activeForeground) - active foreground color
  1239. # global inputBox(anchor) - anchor for message box
  1240. # global inputBox(background) - background color
  1241. # global inputBox(erase) - erase previous text
  1242. # global inputBox(font) - message font
  1243. # global inputBox(foreground) - foreground color
  1244. # global inputBox(justify) - justify for message box
  1245. # global inputBox(scrollActiveForeground) - scrollbar active background color
  1246. # global inputBox(scrollBackground) - scrollbar background color
  1247. # global inputBox(scrollForeground) - scrollbar foreground color
  1248. # global inputBox(scrollSide) - side where scrollbar is located
  1249. # global inputBox(toplevelName) - the toplevel name
  1250. # global inputBox(toplevelName,inputOne) - the text in the entry widget
  1251.  
  1252.   global inputBox
  1253.  
  1254.   if {$inputBox(erase)} {
  1255.     set inputBox($inputBox(toplevelName),inputOne) ""
  1256.   } {
  1257.     if {![info exists inputBox($inputBox(toplevelName),inputOne)]} {
  1258.       set inputBox($inputBox(toplevelName),inputOne) ""
  1259.     }
  1260.   }
  1261.   InputBoxInternal $inputBoxMessage $inputBoxCommandOk $inputBoxCommandCancel $inputBoxGeometry $inputBoxTitle 1
  1262.  
  1263.   # wait for the box to be destroyed
  1264.   update idletask
  1265.   grab $inputBox(toplevelName)
  1266.   tkwait window $inputBox(toplevelName)
  1267.  
  1268.   return $inputBox($inputBox(toplevelName),inputOne)
  1269. }
  1270.  
  1271.  
  1272. # Procedure: IsADir
  1273. proc IsADir { pathName} {
  1274. # xf ignore me 5
  1275. ##########
  1276. # Procedure: IsADir
  1277. # Description: check if name is a directory (including symbolic links)
  1278. # Arguments: pathName - the path to check
  1279. # Returns: 1 if its a directory, otherwise 0
  1280. # Sideeffects: none
  1281. ##########
  1282.  
  1283.   if {[file isdirectory $pathName]} {
  1284.     return 1
  1285.   } {
  1286.     catch "file type $pathName" fileType
  1287.     if {"$fileType" == "link"} {
  1288.       if {[catch "file readlink $pathName" linkName]} {
  1289.         return 0
  1290.       }
  1291.       catch "file type $linkName" fileType
  1292.       while {"$fileType" == "link"} {
  1293.         if {[catch "file readlink $linkName" linkName]} {
  1294.           return 0
  1295.         }
  1296.         catch "file type $linkName" fileType
  1297.       }
  1298.       return [file isdirectory $linkName]
  1299.     }
  1300.   }
  1301.   return 0
  1302. }
  1303.  
  1304.  
  1305. # Procedure: IsAFile
  1306. proc IsAFile { fileName} {
  1307. # xf ignore me 5
  1308. ##########
  1309. # Procedure: IsAFile
  1310. # Description: check if filename is a file (including symbolic links)
  1311. # Arguments: fileName - the filename to check
  1312. # Returns: 1 if its a file, otherwise 0
  1313. # Sideeffects: none
  1314. ##########
  1315.  
  1316.   if {[file isfile $fileName]} {
  1317.     return 1
  1318.   } {
  1319.     catch "file type $fileName" fileType
  1320.     if {"$fileType" == "link"} {
  1321.       if {[catch "file readlink $fileName" linkName]} {
  1322.         return 0
  1323.       }
  1324.       catch "file type $linkName" fileType
  1325.       while {"$fileType" == "link"} {
  1326.         if {[catch "file readlink $linkName" linkName]} {
  1327.           return 0
  1328.         }
  1329.         catch "file type $linkName" fileType
  1330.       }
  1331.       return [file isfile $linkName]
  1332.     }
  1333.   }
  1334.   return 0
  1335. }
  1336.  
  1337.  
  1338. # Procedure: IsASymlink
  1339. proc IsASymlink { fileName} {
  1340. # xf ignore me 5
  1341. ##########
  1342. # Procedure: IsASymlink
  1343. # Description: check if filename is a symbolic link
  1344. # Arguments: fileName - the path/filename to check
  1345. # Returns: none
  1346. # Sideeffects: none
  1347. ##########
  1348.  
  1349.   catch "file type $fileName" fileType
  1350.   if {"$fileType" == "link"} {
  1351.     return 1
  1352.   }
  1353.   return 0
  1354. }
  1355.  
  1356.  
  1357. # Procedure: TextBox
  1358. proc TextBox { {textBoxMessage "Text message"} {textBoxCommand ""} {textBoxGeometry "350x150"} {textBoxTitle "Text box"} args} {
  1359. # xf ignore me 5
  1360. ##########
  1361. # Procedure: TextBox
  1362. # Description: show text box
  1363. # Arguments: {textBoxMessage} - the text to display
  1364. #            {textBoxCommand} - the command to call after ok
  1365. #            {textBoxGeometry} - the geometry for the window
  1366. #            {textBoxTitle} - the title for the window
  1367. #            {args} - labels of buttons
  1368. # Returns: The number of the selected button, or nothing
  1369. # Sideeffects: none
  1370. # Notes: there exist also functions called:
  1371. #          TextBoxFile - to open and read a file automatically
  1372. #          TextBoxFd - to read from an already opened filedescriptor
  1373. ##########
  1374. #
  1375. # global textBox(activeBackground) - active background color
  1376. # global textBox(activeForeground) - active foreground color
  1377. # global textBox(background) - background color
  1378. # global textBox(font) - text font
  1379. # global textBox(foreground) - foreground color
  1380. # global textBox(scrollActiveForeground) - scrollbar active background color
  1381. # global textBox(scrollBackground) - scrollbar background color
  1382. # global textBox(scrollForeground) - scrollbar foreground color
  1383. # global textBox(scrollSide) - side where scrollbar is located
  1384.  
  1385.   global textBox
  1386.  
  1387.   # show text box
  1388.   if {[llength $args] > 0} {
  1389.     eval TextBoxInternal "\{$textBoxMessage\}" "\{$textBoxCommand\}" "\{$textBoxGeometry\}" "\{$textBoxTitle\}" $args
  1390.   } {
  1391.     TextBoxInternal $textBoxMessage $textBoxCommand $textBoxGeometry $textBoxTitle
  1392.   }
  1393.  
  1394.   if {[llength $args] > 0} {
  1395.     # wait for the box to be destroyed
  1396.     update idletask
  1397.     grab $textBox(toplevelName)
  1398.     tkwait window $textBox(toplevelName)
  1399.  
  1400.     return $textBox(button)
  1401.   }
  1402. }
  1403.  
  1404.  
  1405. # Procedure: TextBoxFd
  1406. proc TextBoxFd { {textBoxInFile ""} {textBoxCommand ""} {textBoxGeometry "350x150"} {textBoxTitle "Text box"} args} {
  1407. # xf ignore me 5
  1408. ##########
  1409. # Procedure: TextBoxFd
  1410. # Description: show text box containing a filedescriptor
  1411. # Arguments: {textBoxInFile} - a filedescriptor to read. The descriptor
  1412. #                              is closed after reading
  1413. #            {textBoxCommand} - the command to call after ok
  1414. #            {textBoxGeometry} - the geometry for the window
  1415. #            {textBoxTitle} - the title for the window
  1416. #            {args} - labels of buttons
  1417. # Returns: The number of the selected button, ot nothing
  1418. # Sideeffects: none
  1419. # Notes: there exist also functions called:
  1420. #          TextBox - to display a passed string
  1421. #          TextBoxFile - to open and read a file automatically
  1422. ##########
  1423. #
  1424. # global textBox(activeBackground) - active background color
  1425. # global textBox(activeForeground) - active foreground color
  1426. # global textBox(background) - background color
  1427. # global textBox(font) - text font
  1428. # global textBox(foreground) - foreground color
  1429. # global textBox(scrollActiveForeground) - scrollbar active background color
  1430. # global textBox(scrollBackground) - scrollbar background color
  1431. # global textBox(scrollForeground) - scrollbar foreground color
  1432. # global textBox(scrollSide) - side where scrollbar is located
  1433.  
  1434.   global textBox
  1435.  
  1436.   # check file existance
  1437.   if {"$textBoxInFile" == ""} {
  1438.     puts stderr "No filedescriptor specified"
  1439.     return
  1440.   }
  1441.  
  1442.   set textBoxMessage [read $textBoxInFile]
  1443.   close $textBoxInFile
  1444.  
  1445.   # show text box
  1446.   if {[llength $args] > 0} {
  1447.     eval TextBoxInternal "\{$textBoxMessage\}" "\{$textBoxCommand\}" "\{$textBoxGeometry\}" "\{$textBoxTitle\}" $args
  1448.   } {
  1449.     TextBoxInternal $textBoxMessage $textBoxCommand $textBoxGeometry $textBoxTitle
  1450.   }
  1451.  
  1452.   if {[llength $args] > 0} {
  1453.     # wait for the box to be destroyed
  1454.     update idletask
  1455.     grab $textBox(toplevelName)
  1456.     tkwait window $textBox(toplevelName)
  1457.  
  1458.     return $textBox(button)
  1459.   }
  1460. }
  1461.  
  1462.  
  1463. # Procedure: TextBoxFile
  1464. proc TextBoxFile { {textBoxFile ""} {textBoxCommand ""} {textBoxGeometry "350x150"} {textBoxTitle "Text box"} args} {
  1465. # xf ignore me 5
  1466. ##########
  1467. # Procedure: TextBoxFile
  1468. # Description: show text box containing a file
  1469. # Arguments: {textBoxFile} - filename to read
  1470. #            {textBoxCommand} - the command to call after ok
  1471. #            {textBoxGeometry} - the geometry for the window
  1472. #            {textBoxTitle} - the title for the window
  1473. #            {args} - labels of buttons
  1474. # Returns: The number of the selected button, ot nothing
  1475. # Sideeffects: none
  1476. # Notes: there exist also functions called:
  1477. #          TextBox - to display a passed string
  1478. #          TextBoxFd - to read from an already opened filedescriptor
  1479. ##########
  1480. #
  1481. # global textBox(activeBackground) - active background color
  1482. # global textBox(activeForeground) - active foreground color
  1483. # global textBox(background) - background color
  1484. # global textBox(font) - text font
  1485. # global textBox(foreground) - foreground color
  1486. # global textBox(scrollActiveForeground) - scrollbar active background color
  1487. # global textBox(scrollBackground) - scrollbar background color
  1488. # global textBox(scrollForeground) - scrollbar foreground color
  1489. # global textBox(scrollSide) - side where scrollbar is located
  1490.  
  1491.   global textBox
  1492.  
  1493.   # check file existance
  1494.   if {"$textBoxFile" == ""} {
  1495.     puts stderr "No filename specified"
  1496.     return
  1497.   }
  1498.  
  1499.   if {[catch "open $textBoxFile r" textBoxInFile]} {
  1500.     puts stderr "$textBoxInFile"
  1501.     return
  1502.   }
  1503.  
  1504.   set textBoxMessage [read $textBoxInFile]
  1505.   close $textBoxInFile
  1506.  
  1507.   # show text box
  1508.   if {[llength $args] > 0} {
  1509.     eval TextBoxInternal "\{$textBoxMessage\}" "\{$textBoxCommand\}" "\{$textBoxGeometry\}" "\{$textBoxTitle\}" $args
  1510.   } {
  1511.     TextBoxInternal $textBoxMessage $textBoxCommand $textBoxGeometry $textBoxTitle
  1512.   }
  1513.  
  1514.   if {[llength $args] > 0} {
  1515.     # wait for the box to be destroyed
  1516.     update idletask
  1517.     grab $textBox(toplevelName)
  1518.     tkwait window $textBox(toplevelName)
  1519.  
  1520.     return $textBox(button)
  1521.   }
  1522. }
  1523.  
  1524.  
  1525. # Procedure: TextBoxInternal
  1526. proc TextBoxInternal { textBoxMessage textBoxCommand textBoxGeometry textBoxTitle args} {
  1527. # xf ignore me 6
  1528.   global textBox
  1529.  
  1530.   set tmpButtonOpt ""
  1531.   set tmpFrameOpt ""
  1532.   set tmpMessageOpt ""
  1533.   set tmpScrollOpt ""
  1534.   if {"$textBox(activeBackground)" != ""} {
  1535.     append tmpButtonOpt "-activebackground \"$textBox(activeBackground)\" "
  1536.   }
  1537.   if {"$textBox(activeForeground)" != ""} {
  1538.     append tmpButtonOpt "-activeforeground \"$textBox(activeForeground)\" "
  1539.   }
  1540.   if {"$textBox(background)" != ""} {
  1541.     append tmpButtonOpt "-background \"$textBox(background)\" "
  1542.     append tmpFrameOpt "-background \"$textBox(background)\" "
  1543.     append tmpMessageOpt "-background \"$textBox(background)\" "
  1544.   }
  1545.   if {"$textBox(font)" != ""} {
  1546.     append tmpButtonOpt "-font \"$textBox(font)\" "
  1547.     append tmpMessageOpt "-font \"$textBox(font)\" "
  1548.   }
  1549.   if {"$textBox(foreground)" != ""} {
  1550.     append tmpButtonOpt "-foreground \"$textBox(foreground)\" "
  1551.     append tmpMessageOpt "-foreground \"$textBox(foreground)\" "
  1552.   }
  1553.   if {"$textBox(scrollActiveForeground)" != ""} {
  1554.     append tmpScrollOpt "-activeforeground \"$textBox(scrollActiveForeground)\" "
  1555.   }
  1556.   if {"$textBox(scrollBackground)" != ""} {
  1557.     append tmpScrollOpt "-background \"$textBox(scrollBackground)\" "
  1558.   }
  1559.   if {"$textBox(scrollForeground)" != ""} {
  1560.     append tmpScrollOpt "-foreground \"$textBox(scrollForeground)\" "
  1561.   }
  1562.  
  1563.   # start build of toplevel
  1564.   if {"[info commands XFDestroy]" != ""} {
  1565.     catch {XFDestroy $textBox(toplevelName)}
  1566.   } {
  1567.     catch {destroy $textBox(toplevelName)}
  1568.   }
  1569.   toplevel $textBox(toplevelName)  -borderwidth 0
  1570.   catch "$textBox(toplevelName) config $tmpFrameOpt"
  1571.   if {[catch "wm geometry $textBox(toplevelName) $textBoxGeometry"]} {
  1572.     wm geometry $textBox(toplevelName) 350x150
  1573.   }
  1574.   wm title $textBox(toplevelName) $textBoxTitle
  1575.   wm maxsize $textBox(toplevelName) 1000 1000
  1576.   wm minsize $textBox(toplevelName) 100 100
  1577.   # end build of toplevel
  1578.  
  1579.   frame $textBox(toplevelName).frame0  -borderwidth 0  -relief raised
  1580.   catch "$textBox(toplevelName).frame0 config $tmpFrameOpt"
  1581.  
  1582.   text $textBox(toplevelName).frame0.text1  -relief raised  -wrap none  -borderwidth 2  -yscrollcommand "$textBox(toplevelName).frame0.vscroll set"
  1583.   catch "$textBox(toplevelName).frame0.text1 config $tmpMessageOpt"
  1584.  
  1585.   scrollbar $textBox(toplevelName).frame0.vscroll  -relief raised  -command "$textBox(toplevelName).frame0.text1 yview"
  1586.   catch "$textBox(toplevelName).frame0.vscroll config $tmpScrollOpt"
  1587.  
  1588.   frame $textBox(toplevelName).frame1  -borderwidth 0  -relief raised
  1589.   catch "$textBox(toplevelName).frame1 config $tmpFrameOpt"
  1590.  
  1591.   set textBoxCounter 0
  1592.   set buttonNum [llength $args]
  1593.  
  1594.   if {$buttonNum > 0} {
  1595.     while {$textBoxCounter < $buttonNum} {
  1596.       button $textBox(toplevelName).frame1.button$textBoxCounter  -text "[lindex $args $textBoxCounter]"  -command "
  1597.           global textBox
  1598.           set textBox(button) $textBoxCounter
  1599.           set textBox(contents) \[$textBox(toplevelName).frame0.text1 get 1.0 end\]
  1600.           if {\"\[info commands XFDestroy\]\" != \"\"} {
  1601.             catch {XFDestroy $textBox(toplevelName)}
  1602.           } {
  1603.             catch {destroy $textBox(toplevelName)}
  1604.           }"
  1605.       catch "$textBox(toplevelName).frame1.button$textBoxCounter config $tmpButtonOpt"
  1606.  
  1607.       pack append $textBox(toplevelName).frame1  $textBox(toplevelName).frame1.button$textBoxCounter {left fillx expand}
  1608.  
  1609.       incr textBoxCounter
  1610.     }
  1611.   } {
  1612.     button $textBox(toplevelName).frame1.button0  -text "OK"  -command "
  1613.         global textBox
  1614.         set textBox(button) 0
  1615.         set textBox(contents) \[$textBox(toplevelName).frame0.text1 get 1.0 end\]
  1616.         if {\"\[info commands XFDestroy\]\" != \"\"} {
  1617.           catch {XFDestroy $textBox(toplevelName)}
  1618.         } {
  1619.           catch {destroy $textBox(toplevelName)}
  1620.         }
  1621.         $textBoxCommand"
  1622.     catch "$textBox(toplevelName).frame1.button0 config $tmpButtonOpt"
  1623.  
  1624.     pack append $textBox(toplevelName).frame1  $textBox(toplevelName).frame1.button0 {left fillx expand}
  1625.   }
  1626.  
  1627.   $textBox(toplevelName).frame0.text1 insert end "$textBoxMessage"
  1628.  
  1629.   $textBox(toplevelName).frame0.text1 config  -state $textBox(state)
  1630.  
  1631.   # packing
  1632.   pack append $textBox(toplevelName).frame0  $textBox(toplevelName).frame0.vscroll "$textBox(scrollSide) filly"  $textBox(toplevelName).frame0.text1 {left fill expand}
  1633.   pack append $textBox(toplevelName)  $textBox(toplevelName).frame1 {bottom fill}  $textBox(toplevelName).frame0 {top fill expand}
  1634. }
  1635.  
  1636.  
  1637. # Procedure: VersionAlertBox
  1638. proc VersionAlertBox {} {
  1639.   global Ident
  1640.   AlertBox [format "Role Playing DataBase system V1.0\n\n%s" $Ident] "" 400x80
  1641. }
  1642.  
  1643.  
  1644. # Procedure: YesNoBox
  1645. proc YesNoBox { {yesNoBoxMessage "Yes/no message"} {yesNoBoxGeometry "350x150"}} {
  1646. # xf ignore me 5
  1647. ##########
  1648. # Procedure: YesNoBox
  1649. # Description: show yesno box
  1650. # Arguments: {yesNoBoxMessage} - the text to display
  1651. #            {yesNoBoxGeometry} - the geometry for the window
  1652. # Returns: none
  1653. # Sideeffects: none
  1654. ##########
  1655. #
  1656. # global yesNoBox(activeBackground) - active background color
  1657. # global yesNoBox(activeForeground) - active foreground color
  1658. # global yesNoBox(anchor) - anchor for message box
  1659. # global yesNoBox(background) - background color
  1660. # global yesNoBox(font) - message font
  1661. # global yesNoBox(foreground) - foreground color
  1662. # global yesNoBox(justify) - justify for message box
  1663. # global yesNoBox(afterNo) - destroy yes-no box after n seconds.
  1664. #                            The no button is activated
  1665. # global yesNoBox(afterYes) - destroy yes-no box after n seconds.
  1666. #                             The yes button is activated
  1667.  
  1668.   global yesNoBox
  1669.  
  1670.   set tmpButtonOpt ""
  1671.   set tmpFrameOpt ""
  1672.   set tmpMessageOpt ""
  1673.   if {"$yesNoBox(activeBackground)" != ""} {
  1674.     append tmpButtonOpt "-activebackground \"$yesNoBox(activeBackground)\" "
  1675.   }
  1676.   if {"$yesNoBox(activeForeground)" != ""} {
  1677.     append tmpButtonOpt "-activeforeground \"$yesNoBox(activeForeground)\" "
  1678.   }
  1679.   if {"$yesNoBox(background)" != ""} {
  1680.     append tmpButtonOpt "-background \"$yesNoBox(background)\" "
  1681.     append tmpFrameOpt "-background \"$yesNoBox(background)\" "
  1682.     append tmpMessageOpt "-background \"$yesNoBox(background)\" "
  1683.   }
  1684.   if {"$yesNoBox(font)" != ""} {
  1685.     append tmpButtonOpt "-font \"$yesNoBox(font)\" "
  1686.     append tmpMessageOpt "-font \"$yesNoBox(font)\" "
  1687.   }
  1688.   if {"$yesNoBox(foreground)" != ""} {
  1689.     append tmpButtonOpt "-foreground \"$yesNoBox(foreground)\" "
  1690.     append tmpMessageOpt "-foreground \"$yesNoBox(foreground)\" "
  1691.   }
  1692.  
  1693.   # start build of toplevel
  1694.   if {"[info commands XFDestroy]" != ""} {
  1695.     catch {XFDestroy .yesNoBox}
  1696.   } {
  1697.     catch {destroy .yesNoBox}
  1698.   }
  1699.   toplevel .yesNoBox  -borderwidth 0
  1700.   catch ".yesNoBox config $tmpFrameOpt"
  1701.   if {[catch "wm geometry .yesNoBox $yesNoBoxGeometry"]} {
  1702.     wm geometry .yesNoBox 350x150
  1703.   }
  1704.   wm title .yesNoBox {Alert box}
  1705.   wm maxsize .yesNoBox 1000 1000
  1706.   wm minsize .yesNoBox 100 100
  1707.   # end build of toplevel
  1708.  
  1709.   message .yesNoBox.message1  -anchor "$yesNoBox(anchor)"  -justify "$yesNoBox(justify)"  -relief raised  -text "$yesNoBoxMessage"
  1710.   catch ".yesNoBox.message1 config $tmpMessageOpt"
  1711.  
  1712.   set xfTmpWidth  [string range $yesNoBoxGeometry 0 [expr [string first x $yesNoBoxGeometry]-1]]
  1713.   if {"$xfTmpWidth" != ""} {
  1714.     # set message size
  1715.     catch ".yesNoBox.message1 configure  -width [expr $xfTmpWidth-10]"
  1716.   } {
  1717.     .yesNoBox.message1 configure  -aspect 1500
  1718.   }
  1719.  
  1720.   frame .yesNoBox.frame1  -borderwidth 0  -relief raised
  1721.   catch ".yesNoBox.frame1 config $tmpFrameOpt"
  1722.  
  1723.   button .yesNoBox.frame1.button0  -text "Yes"  -command "
  1724.       global yesNoBox
  1725.       set yesNoBox(button) 1
  1726.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  1727.         catch {XFDestroy .yesNoBox}
  1728.       } {
  1729.         catch {destroy .yesNoBox}
  1730.       }"
  1731.   catch ".yesNoBox.frame1.button0 config $tmpButtonOpt"
  1732.  
  1733.   button .yesNoBox.frame1.button1  -text "No"  -command "
  1734.       global yesNoBox
  1735.       set yesNoBox(button) 0
  1736.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  1737.         catch {XFDestroy .yesNoBox}
  1738.       } {
  1739.         catch {destroy .yesNoBox}
  1740.       }"
  1741.   catch ".yesNoBox.frame1.button1 config $tmpButtonOpt"
  1742.  
  1743.   pack append .yesNoBox.frame1  .yesNoBox.frame1.button0 {left fillx expand}  .yesNoBox.frame1.button1 {left fillx expand}
  1744.  
  1745.   # packing
  1746.   pack append .yesNoBox  .yesNoBox.frame1 {bottom fill}  .yesNoBox.message1 {top fill expand}
  1747.  
  1748.   if {$yesNoBox(afterYes) != 0} {
  1749.     after [expr $yesNoBox(afterYes)*1000]  "catch \".yesNoBox.frame1.button0 invoke\""
  1750.   }
  1751.   if {$yesNoBox(afterNo) != 0} {
  1752.     after [expr $yesNoBox(afterNo)*1000]  "catch \".yesNoBox.frame1.button1 invoke\""
  1753.   }
  1754.  
  1755.   # wait for the box to be destroyed
  1756.   update idletask
  1757.   grab .yesNoBox
  1758.   tkwait window .yesNoBox
  1759.  
  1760.   return $yesNoBox(button)
  1761. }
  1762.  
  1763.  
  1764. # Internal procedures
  1765.  
  1766.  
  1767. # Procedure: Alias
  1768. proc Alias { args} {
  1769. # xf ignore me 7
  1770. ##########
  1771. # Procedure: Alias
  1772. # Description: establish an alias for a procedure
  1773. # Arguments: args - no argument means that a list of all aliases
  1774. #                   is returned. Otherwise the first parameter is
  1775. #                   the alias name, and the second parameter is
  1776. #                   the procedure that is aliased.
  1777. # Returns: nothing, the command that is bound to the alias or a
  1778. #          list of all aliases - command pairs. 
  1779. # Sideeffects: internalAliasList is updated, and the alias
  1780. #              proc is inserted
  1781. ##########
  1782.   global internalAliasList
  1783.  
  1784.   if {[llength $args] == 0} {
  1785.     return $internalAliasList
  1786.   } {
  1787.     if {[llength $args] == 1} {
  1788.       set xfTmpIndex [lsearch $internalAliasList "[lindex $args 0] *"]
  1789.       if {$xfTmpIndex != -1} {
  1790.         return [lindex [lindex $internalAliasList $xfTmpIndex] 1]
  1791.       }
  1792.     } {
  1793.       if {[llength $args] == 2} {
  1794.         eval "proc [lindex $args 0] {args} {#xf ignore me 4
  1795. return \[eval \"[lindex $args 1] \$args\"\]}"
  1796.         set xfTmpIndex [lsearch $internalAliasList "[lindex $args 0] *"]
  1797.         if {$xfTmpIndex != -1} {
  1798.           set internalAliasList [lreplace $internalAliasList $xfTmpIndex $xfTmpIndex "[lindex $args 0] [lindex $args 1]"]
  1799.         } {
  1800.           lappend internalAliasList "[lindex $args 0] [lindex $args 1]"
  1801.         }
  1802.       } {
  1803.         error "Alias: wrong number or args: $args"
  1804.       }
  1805.     }
  1806.   }
  1807. }
  1808.  
  1809.  
  1810. # Procedure: GetSelection
  1811. if {"[info procs GetSelection]" == ""} {
  1812. proc GetSelection {} {
  1813. # xf ignore me 7
  1814. ##########
  1815. # Procedure: GetSelection
  1816. # Description: get current selection
  1817. # Arguments: none
  1818. # Returns: none
  1819. # Sideeffects: none
  1820. ##########
  1821.  
  1822.   # the save way
  1823.   set xfSelection ""
  1824.   catch "selection get" xfSelection
  1825.   if {"$xfSelection" == "selection doesn't exist or form \"STRING\" not defined"} {
  1826.     return ""
  1827.   } {
  1828.     return $xfSelection
  1829.   }
  1830. }
  1831. }
  1832.  
  1833.  
  1834. # Procedure: Unalias
  1835. proc Unalias { aliasName} {
  1836. # xf ignore me 7
  1837. ##########
  1838. # Procedure: Unalias
  1839. # Description: remove an alias for a procedure
  1840. # Arguments: aliasName - the alias name to remove
  1841. # Returns: none
  1842. # Sideeffects: internalAliasList is updated, and the alias
  1843. #              proc is removed
  1844. ##########
  1845.   global internalAliasList
  1846.  
  1847.   set xfIndex [lsearch $internalAliasList "$aliasName *"]
  1848.   if {$xfIndex != -1} {
  1849.     rename $aliasName ""
  1850.     set internalAliasList [lreplace $internalAliasList $xfIndex $xfIndex]
  1851.   }
  1852. }
  1853.  
  1854. # XFNoParsing
  1855. # Program: template
  1856. # Description: select colors
  1857. #
  1858. # The HSV <-> RGB converting routines are from the
  1859. # tcolor demo that is part of the demo site of Tk.
  1860. #
  1861. # $Header: /home/heller/Deepwoods/RolePlaying/RCS/SYSFunctions,v 1.3 1995/07/03 18:24:02 heller Exp $
  1862.  
  1863. proc ColorBox {{colorBoxFileColor "/usr/local/lib/xf/lib/Colors"} {colorBoxMessage "Color"} {colorBoxEntryW ""} {colorBoxTargetW ""}} {# xf ignore me 5
  1864. ##########
  1865. # Procedure: ColorBox
  1866. # Description: select a color
  1867. # Arguments: {colorBoxFileColor} - the color file with all colornames
  1868. #            {colorBoxMessage} - a message to display
  1869. #            {colorBoxEntryW} - the widget name for the resulting color name
  1870. #            {colorBoxTargetW} - the widget we configure
  1871. # Returns: colorname, or nothing
  1872. # Sideeffects: none
  1873. ##########
  1874. # 
  1875. # global colorBox(activeBackground) - active background color
  1876. # global colorBox(activeForeground) - active foreground color
  1877. # global colorBox(background) - background color
  1878. # global colorBox(font) - text font
  1879. # global colorBox(foreground) - foreground color
  1880. # global colorBox(palette) - a palette of colors
  1881. # global colorBox(scrollActiveForeground) - scrollbar active background color
  1882. # global colorBox(scrollBackground) - scrollbar background color
  1883. # global colorBox(scrollForeground) - scrollbar foreground color
  1884. # global colorBox(scrollSide) - side where scrollbar is located
  1885.  
  1886.   global colorBox
  1887.  
  1888.   set colorBox(colorName) ""
  1889.   set colorBox(paletteNr) 0
  1890.  
  1891.   set tmpButtonOpt ""
  1892.   set tmpFrameOpt ""
  1893.   set tmpMessageOpt ""
  1894.   set tmpScaleOpt ""
  1895.   set tmpScrollOpt ""
  1896.   if {"$colorBox(activeBackground)" != ""} {
  1897.     append tmpButtonOpt "-activebackground \"$colorBox(activeBackground)\" "
  1898.   }
  1899.   if {"$colorBox(activeForeground)" != ""} {
  1900.     append tmpButtonOpt "-activeforeground \"$colorBox(activeForeground)\" "
  1901.   }
  1902.   if {"$colorBox(background)" != ""} {
  1903.     append tmpButtonOpt "-background \"$colorBox(background)\" "
  1904.     append tmpFrameOpt "-background \"$colorBox(background)\" "
  1905.     append tmpMessageOpt "-background \"$colorBox(background)\" "
  1906.     append tmpScaleOpt "-background \"$colorBox(background)\" "
  1907.   }
  1908.   if {"$colorBox(font)" != ""} {
  1909.     append tmpButtonOpt "-font \"$colorBox(font)\" "
  1910.     append tmpMessageOpt "-font \"$colorBox(font)\" "
  1911.   }
  1912.   if {"$colorBox(foreground)" != ""} {
  1913.     append tmpButtonOpt "-foreground \"$colorBox(foreground)\" "
  1914.     append tmpMessageOpt "-foreground \"$colorBox(foreground)\" "
  1915.     append tmpScaleOpt "-foreground \"$colorBox(foreground)\" "
  1916.   }
  1917.   if {"$colorBox(scrollActiveForeground)" != ""} {
  1918.     append tmpScaleOpt "-activeforeground \"$colorBox(scrollActiveForeground)\" "
  1919.     append tmpScrollOpt "-activeforeground \"$colorBox(scrollActiveForeground)\" "
  1920.   }
  1921.   if {"$colorBox(scrollBackground)" != ""} {
  1922.     append tmpScrollOpt "-background \"$colorBox(scrollBackground)\" "
  1923.   }
  1924.   if {"$colorBox(scrollForeground)" != ""} {
  1925.     append tmpScrollOpt "-foreground \"$colorBox(scrollForeground)\" "
  1926.   }
  1927.  
  1928.   # get color file name
  1929.   if {!([file exists $colorBoxFileColor] &&
  1930.         [file readable $colorBoxFileColor])} {
  1931.     set colorBoxFileColor ""
  1932.   }
  1933.   if {"$colorBoxFileColor" == ""} {
  1934.     global env
  1935.     if {[info exists env(XF_COLOR_FILE)]} {
  1936.       if {[file exists $env(XF_COLOR_FILE)] &&
  1937.           [file readable $env(XF_COLOR_FILE)]} {
  1938.         set colorBoxFileColor $env(XF_COLOR_FILE)
  1939.       }
  1940.     }
  1941.   }
  1942.   if {"$colorBoxMessage" == ""} {
  1943.     set colorBoxMessage "Color"
  1944.   }
  1945.  
  1946.   # save the the current widget color
  1947.   if {"$colorBoxTargetW" != ""} {
  1948.     if {[catch "$colorBoxTargetW config -[string tolower $colorBoxMessage]" result]} {
  1949.       set colorBoxSavedColor ""
  1950.     } {
  1951.       set colorBoxSavedColor [lindex $result 4]
  1952.     }
  1953.   } {
  1954.     set colorBoxSavedColor ""
  1955.   }
  1956.  
  1957.   # look if there is already a color window
  1958.   if {"[info commands .colorBox]" == ""} {
  1959.     # build widget structure
  1960.  
  1961.     # start build of toplevel
  1962.     if {"[info commands XFDestroy]" != ""} {
  1963.       catch {XFDestroy .colorBox}
  1964.     } {
  1965.       catch {destroy .colorBox}
  1966.     }
  1967.     toplevel .colorBox \
  1968.       -borderwidth 0
  1969.     catch ".colorBox config $tmpFrameOpt"
  1970.     wm geometry .colorBox 400x250
  1971.     wm title .colorBox {Color box}
  1972.     wm maxsize .colorBox 1000 1000
  1973.     wm minsize .colorBox 100 100
  1974.     # end build of toplevel
  1975.  
  1976.     set colorBox(oldWidget) $colorBoxEntryW
  1977.  
  1978.     frame .colorBox.frame1 \
  1979.       -borderwidth 0 \
  1980.       -relief raised
  1981.     catch ".colorBox.frame1 config $tmpFrameOpt"
  1982.  
  1983.     button .colorBox.frame1.ok \
  1984.       -text "OK"
  1985.     catch ".colorBox.frame1.ok config $tmpButtonOpt"
  1986.  
  1987.     button .colorBox.frame1.cancel \
  1988.       -text "Cancel"
  1989.     catch ".colorBox.frame1.cancel config $tmpButtonOpt"
  1990.  
  1991.     frame .colorBox.frame2 \
  1992.       -borderwidth 0 \
  1993.       -relief raised
  1994.     catch ".colorBox.frame2 config $tmpFrameOpt"
  1995.  
  1996.     radiobutton .colorBox.frame2.rgb \
  1997.       -command "ColorBoxShowSlides $colorBoxMessage \"$colorBoxTargetW\"" \
  1998.       -text "RGB" \
  1999.       -variable colorBox(type)
  2000.     catch ".colorBox.frame2.rgb config $tmpButtonOpt"
  2001.  
  2002.     radiobutton .colorBox.frame2.hsv \
  2003.       -command "ColorBoxShowSlides $colorBoxMessage \"$colorBoxTargetW\"" \
  2004.       -text "HSV" \
  2005.       -variable colorBox(type)
  2006.     catch ".colorBox.frame2.hsv config $tmpButtonOpt"
  2007.  
  2008.     radiobutton .colorBox.frame2.list \
  2009.       -command "ColorBoxShowSlides $colorBoxMessage \"$colorBoxTargetW\"" \
  2010.       -text "List" \
  2011.       -variable colorBox(type)
  2012.     catch ".colorBox.frame2.list config $tmpButtonOpt"
  2013.  
  2014.     frame .colorBox.palette \
  2015.       -borderwidth 0 \
  2016.       -relief raised
  2017.     catch ".colorBox.palette config $tmpFrameOpt"
  2018.  
  2019.     set counter 0
  2020.     foreach element $colorBox(palette) {
  2021.       button .colorBox.palette.palette$counter \
  2022.         -command "ColorBoxSetPalette $colorBoxMessage \"$colorBoxTargetW\" $counter" \
  2023.                -width 3
  2024.       catch ".colorBox.palette.palette$counter config \
  2025.         -activebackground \"$element\" \
  2026.         -background \"$element\""
  2027.  
  2028.       pack append .colorBox.palette .colorBox.palette.palette$counter {left fill expand}
  2029.       incr counter
  2030.     }
  2031.  
  2032.     scale .colorBox.red \
  2033.       -background "red" \
  2034.       -from 0 \
  2035.       -label "Red" \
  2036.       -orient horizontal \
  2037.       -relief raised \
  2038.       -sliderlength 15 \
  2039.       -to 255 \
  2040.       -width 8
  2041.     catch ".colorBox.red config $tmpScaleOpt"
  2042.  
  2043.     scale .colorBox.green \
  2044.       -background "green" \
  2045.       -from 0 \
  2046.       -label "Green" \
  2047.       -orient horizontal \
  2048.       -relief raised \
  2049.       -sliderlength 15 \
  2050.       -to 255 \
  2051.       -width 8
  2052.     catch ".colorBox.green config $tmpScaleOpt"
  2053.  
  2054.     scale .colorBox.blue \
  2055.       -background "blue" \
  2056.       -from 0 \
  2057.       -label "Blue" \
  2058.       -orient horizontal \
  2059.       -relief raised \
  2060.       -sliderlength 15 \
  2061.       -to 255 \
  2062.       -width 8
  2063.     catch ".colorBox.blue config $tmpScaleOpt"
  2064.  
  2065.     scale .colorBox.h \
  2066.       -from 0 \
  2067.       -label "Hue" \
  2068.       -orient horizontal \
  2069.       -relief raised \
  2070.       -sliderlength 15 \
  2071.       -to 1000 \
  2072.       -width 8
  2073.     catch ".colorBox.h config $tmpScaleOpt"
  2074.  
  2075.    scale .colorBox.s \
  2076.      -from 0 \
  2077.      -label "Saturation * 100" \
  2078.      -orient horizontal \
  2079.      -relief raised \
  2080.      -sliderlength 15 \
  2081.      -to 1000 \
  2082.      -width 8
  2083.     catch ".colorBox.s config $tmpScaleOpt"
  2084.  
  2085.     scale .colorBox.v \
  2086.       -from 0 \
  2087.       -label "Value" \
  2088.       -orient horizontal \
  2089.       -relief raised \
  2090.       -sliderlength 15 \
  2091.       -to 1000 \
  2092.       -width 8
  2093.     catch ".colorBox.v config $tmpScaleOpt"
  2094.  
  2095.     label .colorBox.demo \
  2096.       -relief raised \
  2097.       -text "This text shows the results :-)"
  2098.     catch ".colorBox.demo config $tmpMessageOpt"
  2099.  
  2100.     frame .colorBox.current \
  2101.       -borderwidth 0 \
  2102.       -relief raised
  2103.     catch ".colorBox.current config $tmpFrameOpt"
  2104.  
  2105.     label .colorBox.current.labelcurrent \
  2106.       -relief raised
  2107.     catch ".colorBox.current.labelcurrent config $tmpMessageOpt"
  2108.  
  2109.     entry .colorBox.current.current \
  2110.       -relief raised
  2111.     catch ".colorBox.current.current config $tmpMessageOpt"
  2112.  
  2113.     frame .colorBox.colors \
  2114.       -borderwidth 0 \
  2115.       -relief raised
  2116.     catch ".colorBox.colors config $tmpFrameOpt"
  2117.  
  2118.     scrollbar .colorBox.colors.vscroll \
  2119.       -relief raised \
  2120.       -command ".colorBox.colors.colors yview"
  2121.     catch ".colorBox.colors.vscroll config $tmpScrollOpt"
  2122.  
  2123.     scrollbar .colorBox.colors.hscroll \
  2124.       -orient horiz \
  2125.       -relief raised \
  2126.       -command ".colorBox.colors.colors xview"
  2127.     catch ".colorBox.colors.hscroll config $tmpScrollOpt"
  2128.  
  2129.     listbox .colorBox.colors.colors \
  2130.       -exportselection false \
  2131.       -relief raised \
  2132.       -xscrollcommand ".colorBox.colors.hscroll set" \
  2133.       -yscrollcommand ".colorBox.colors.vscroll set"
  2134.     catch ".colorBox.colors.colors config $tmpMessageOpt"
  2135.  
  2136.     # read color file
  2137.     if {"$colorBoxFileColor" != ""} {
  2138.       if {[catch "open $colorBoxFileColor r" colorInFile]} {
  2139.         set colorBoxFileColor ""
  2140.         if {"[info commands AlertBox]" != ""} {
  2141.           AlertBox "$colorInFile"
  2142.         } {
  2143.           puts stderr "$colorInFile"
  2144.         }
  2145.       } {
  2146.         set colorReadList [read $colorInFile]
  2147.         close $colorInFile
  2148.         foreach colorLine [split $colorReadList "\n"] {
  2149.           if {"[string trim $colorLine]" != ""} {
  2150.             set colorNewLine [lrange $colorLine 3 end]
  2151.             append colorNewLine " " [format #%02x [lindex $colorLine 0]]
  2152.             append colorNewLine [format %02x [lindex $colorLine 1]]
  2153.             append colorNewLine [format %02x [lindex $colorLine 2]]
  2154.             .colorBox.colors.colors insert end $colorNewLine
  2155.           }
  2156.         }
  2157.       }
  2158.     }
  2159.  
  2160.     # bindings
  2161.     bind .colorBox.colors.colors <ButtonPress-1> "
  2162.       ColorBoxSelectColor %W $colorBoxMessage \"$colorBoxTargetW\" %y"
  2163.     bind .colorBox.colors.colors <Button1-Motion> "
  2164.       ColorBoxSelectColor %W $colorBoxMessage \"$colorBoxTargetW\" %y"
  2165.     bind .colorBox.colors.colors <Shift-ButtonPress-1> "
  2166.       ColorBoxSelectColor %W $colorBoxMessage \"$colorBoxTargetW\" %y"
  2167.     bind .colorBox.colors.colors <Shift-Button1-Motion> "
  2168.       ColorBoxSelectColor %W $colorBoxMessage \"$colorBoxTargetW\" %y"
  2169.   } {
  2170.     if {"[winfo class $colorBox(oldWidget)]" == "Text"} {
  2171.       catch "$colorBox(oldWidget) delete 1.0 end"
  2172.       catch "$colorBox(oldWidget) insert 1.0 [.colorBox.current.current get]"
  2173.     } {
  2174.       if {"[winfo class $colorBox(oldWidget)]" == "Entry"} {
  2175.         catch "$colorBox(oldWidget) delete 0 end"
  2176.         catch "$colorBox(oldWidget) insert 0 [.colorBox.current.current get]"
  2177.       }
  2178.     }
  2179.  
  2180.     set colorBox(oldWidget) $colorBoxEntryW
  2181.   }
  2182.    
  2183.   .colorBox.frame1.ok config \
  2184.     -command "
  2185.       global colorBox
  2186.       set colorBox(colorName) \[.colorBox.current.current get\]
  2187.       if {\"$colorBoxEntryW\" != \"\"} {
  2188.         if {\"\[winfo class $colorBoxEntryW\]\" == \"Text\"} {
  2189.           catch \"$colorBoxEntryW delete 1.0 end\"
  2190.           catch \"$colorBoxEntryW insert 1.0 \\\"\$colorBox(colorName)\\\"\"
  2191.         } {
  2192.           if {\"\[winfo class $colorBoxEntryW\]\" == \"Entry\"} {
  2193.             catch \"$colorBoxEntryW delete 0 end\"
  2194.             catch \"$colorBoxEntryW insert 0 \\\"\$colorBox(colorName)\\\"\"
  2195.           }
  2196.         }
  2197.       }
  2198.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  2199.         catch {XFDestroy .colorBox}
  2200.       } {
  2201.         catch {destroy .colorBox}
  2202.       }"
  2203.  
  2204.   .colorBox.frame1.cancel config \
  2205.     -command "
  2206.       global colorBox
  2207.       set colorBox(colorName) {}
  2208.       if {\"$colorBoxTargetW\" != \"\"} {
  2209.         catch \"$colorBoxTargetW config -\[string tolower $colorBoxMessage\] $colorBoxSavedColor\"
  2210.       }
  2211.       if {\"\[info commands XFDestroy\]\" != \"\"} {
  2212.         catch {XFDestroy .colorBox}
  2213.       } {
  2214.         catch {destroy .colorBox}
  2215.       }"
  2216.  
  2217.   .colorBox.red config \
  2218.     -command "ColorBoxSetRGBColor $colorBoxMessage \"$colorBoxTargetW\""
  2219.  
  2220.   .colorBox.green config \
  2221.     -command "ColorBoxSetRGBColor $colorBoxMessage \"$colorBoxTargetW\""
  2222.  
  2223.   .colorBox.blue config \
  2224.     -command "ColorBoxSetRGBColor $colorBoxMessage \"$colorBoxTargetW\""
  2225.  
  2226.   .colorBox.h config \
  2227.     -command "ColorBoxSetHSVColor $colorBoxMessage \"$colorBoxTargetW\""
  2228.  
  2229.   .colorBox.s config \
  2230.     -command "ColorBoxSetHSVColor $colorBoxMessage \"$colorBoxTargetW\""
  2231.  
  2232.   .colorBox.v config \
  2233.     -command "ColorBoxSetHSVColor $colorBoxMessage \"$colorBoxTargetW\""
  2234.  
  2235.   .colorBox.current.labelcurrent config \
  2236.     -text "$colorBoxMessage:"
  2237.  
  2238.   # bindings
  2239.   bind .colorBox.current.current <Return> "
  2240.     ColorBoxSetPaletteList \[.colorBox.current.current get\]
  2241.     ColorBoxSetColor $colorBoxMessage \"$colorBoxTargetW\" text \[.colorBox.current.current get\]"
  2242.  
  2243.   bind .colorBox.colors.colors <Double-1> "
  2244.     ColorBoxSelectColor %W $colorBoxMessage \"$colorBoxTargetW\" %y
  2245.     global colorBox
  2246.     set colorBox(colorName) \[.colorBox.current.current get\]
  2247.     if {\"$colorBoxEntryW\" != \"\"} {
  2248.       if {\"\[winfo class $colorBoxEntryW\]\" == \"Text\"} {
  2249.         catch \"$colorBoxEntryW delete 1.0 end\"
  2250.         catch \"$colorBoxEntryW insert 1.0 \\\"\$colorBox(colorName)\\\"\"
  2251.       } {
  2252.         if {\"\[winfo class $colorBoxEntryW\]\" == \"Entry\"} {
  2253.           catch \"$colorBoxEntryW delete 0 end\"
  2254.           catch \"$colorBoxEntryW insert 0 \\\"\$colorBox(colorName)\\\"\"
  2255.         }
  2256.       }
  2257.     }
  2258.     if {\"\[info commands XFDestroy\]\" != \"\"} {
  2259.       catch {XFDestroy .colorBox}
  2260.     } {
  2261.       catch {destroy .colorBox}
  2262.     }"
  2263.  
  2264.   # set up current value
  2265.   .colorBox.current.current delete 0 end
  2266.   if {"$colorBoxEntryW" != ""} {
  2267.     if {"[winfo class $colorBoxEntryW]" == "Text"} {
  2268.       .colorBox.current.current insert 0 [$colorBoxEntryW get 1.0 end]
  2269.     } {
  2270.       if {"[winfo class $colorBoxEntryW]" == "Entry"} {
  2271.         .colorBox.current.current insert 0 [$colorBoxEntryW get]
  2272.       }
  2273.     }
  2274.   }
  2275.   if {"[.colorBox.current.current get]" != ""} {
  2276.     ColorBoxSetColor $colorBoxMessage $colorBoxTargetW text [.colorBox.current.current get]
  2277.   }
  2278.     
  2279.   # packing
  2280.   pack append .colorBox.frame1 \
  2281.               .colorBox.frame1.ok {left fill expand} \
  2282.               .colorBox.frame1.cancel {left fill expand}
  2283.   pack append .colorBox.frame2 \
  2284.               .colorBox.frame2.rgb {left fill expand} \
  2285.               .colorBox.frame2.hsv {left fill expand} \
  2286.               .colorBox.frame2.list {left fill expand}
  2287.   pack append .colorBox.current \
  2288.               .colorBox.current.labelcurrent {left} \
  2289.               .colorBox.current.current {left fill expand}
  2290.   pack append .colorBox.colors \
  2291.               .colorBox.colors.vscroll "$colorBox(scrollSide) filly" \
  2292.               .colorBox.colors.hscroll {bottom fillx} \
  2293.               .colorBox.colors.colors {left fill expand}
  2294.  
  2295.   ColorBoxShowSlides $colorBoxMessage $colorBoxTargetW
  2296.  
  2297.   catch "wm deiconify .colorBox"
  2298.  
  2299.   if {"$colorBoxEntryW" == ""} {
  2300.     # wait for the box to be destroyed
  2301.     update idletask
  2302.     grab .colorBox
  2303.     tkwait window .colorBox
  2304.  
  2305.     return $colorBox(colorName)
  2306.   }
  2307. }
  2308.  
  2309. ##########
  2310. # Procedure: ColorBoxSelectColor
  2311. # Description: select color for color composing
  2312. # Arguments: colorW - the widget
  2313. #            colorBoxMessage - the message for the color
  2314. #            colorBoxTargetW - the widget we configure
  2315. #            colorY - the y position in the listbox
  2316. # Returns: none
  2317. # Sideeffects: none
  2318. ##########
  2319. proc ColorBoxSelectColor {colorW colorBoxMessage colorBoxTargetW colorY} {# xf ignore me 6
  2320.  
  2321.   set colorNearest [$colorW nearest $colorY]
  2322.   if {$colorNearest >= 0} {
  2323.     $colorW select from $colorNearest
  2324.     $colorW select to $colorNearest
  2325.     set colorTmpValue [$colorW get $colorNearest]
  2326.     set colorCurrentColor [lrange $colorTmpValue 0 \
  2327.           [expr [llength $colorTmpValue]-2]]
  2328.     set colorCurrentValue [lrange $colorTmpValue \
  2329.           [expr [llength $colorTmpValue]-1] end]
  2330.  
  2331.     scan [string range $colorCurrentValue 1 2] "%x" colorBoxValue
  2332.     .colorBox.red set $colorBoxValue
  2333.     scan [string range $colorCurrentValue 3 4] "%x" colorBoxValue
  2334.     .colorBox.green set $colorBoxValue
  2335.     scan [string range $colorCurrentValue 5 6] "%x" colorBoxValue
  2336.     .colorBox.blue set $colorBoxValue
  2337.  
  2338.     .colorBox.current.current delete 0 end
  2339.     .colorBox.current.current insert 0 $colorCurrentColor
  2340.     ColorBoxSetColor $colorBoxMessage $colorBoxTargetW list $colorCurrentColor
  2341.     ColorBoxSetPaletteList $colorCurrentColor
  2342.   }
  2343. }
  2344.  
  2345. ##########
  2346. # Procedure: ColorBoxSetColor
  2347. # Description: set the new color
  2348. # Arguments: colorBoxMessage - the message for the color
  2349. #            colorBoxTargetW - the widget we configure
  2350. #            colorBoxType - who wants to set the demo area
  2351. #            colorBoxValue - the value to set
  2352. # Returns: none
  2353. # Sideeffects: none
  2354. ##########
  2355. proc ColorBoxSetColor {colorBoxMessage colorBoxTargetW colorBoxType colorBoxValue} {# xf ignore me 6
  2356.   global colorBox
  2357.  
  2358.   .colorBox.red config \
  2359.     -command "NoFunction"
  2360.   .colorBox.green config \
  2361.     -command "NoFunction"
  2362.   .colorBox.blue config \
  2363.     -command "NoFunction"
  2364.   .colorBox.h config \
  2365.     -command "NoFunction"
  2366.   .colorBox.s config \
  2367.     -command "NoFunction"
  2368.   .colorBox.v config \
  2369.     -command "NoFunction"
  2370.  
  2371.   set colorBoxSetColor ""
  2372.   if {"$colorBoxValue" != ""} {
  2373.     if {"$colorBoxType" != "text"} {
  2374.       .colorBox.current.current delete 0 end
  2375.       .colorBox.current.current insert 0 $colorBoxValue
  2376.     }
  2377.     if {[string match "*oreground*" $colorBoxMessage]} {
  2378.       catch ".colorBox.demo config -foreground $colorBoxValue"
  2379.     } {
  2380.       catch ".colorBox.demo config -background $colorBoxValue"
  2381.     }
  2382.     if {"$colorBoxTargetW" != ""} {
  2383.       catch "$colorBoxTargetW config -[string tolower $colorBoxMessage] \
  2384.         $colorBoxValue"
  2385.     }
  2386.   }
  2387.   case $colorBoxType in {
  2388.     {text palette} {
  2389.       if {[string match "*oreground*" $colorBoxMessage]} {
  2390.         set red [expr [lindex [winfo rgb .colorBox.demo [lindex [.colorBox.demo config -foreground] 4]] 0]/256]
  2391.         set green [expr [lindex [winfo rgb .colorBox.demo [lindex [.colorBox.demo config -foreground] 4]] 1]/256]
  2392.         set blue [expr [lindex [winfo rgb .colorBox.demo [lindex [.colorBox.demo config -foreground] 4]] 2]/256]
  2393.       } {
  2394.         set red [expr [lindex [winfo rgb .colorBox.demo [lindex [.colorBox.demo config -background] 4]] 0]/256]
  2395.         set green [expr [lindex [winfo rgb .colorBox.demo [lindex [.colorBox.demo config -background] 4]] 1]/256]
  2396.         set blue [expr [lindex [winfo rgb .colorBox.demo [lindex [.colorBox.demo config -background] 4]] 2]/256]
  2397.       }
  2398.       if {"$colorBox(type)" == "rgb"} {
  2399.         .colorBox.red set $red
  2400.         .colorBox.green set $green
  2401.         .colorBox.blue set $blue
  2402.       } {
  2403.         if {"$colorBox(type)" == "hsv"} {
  2404.           set colorBoxHSV [ColorBoxRGBToHSV [expr $red*256] [expr $green*256] [expr $blue*256]]
  2405.           .colorBox.h set [format %.0f [expr [lindex $colorBoxHSV 0]*1000.0]]
  2406.           .colorBox.s set [format %.0f [expr [lindex $colorBoxHSV 1]*1000.0]]
  2407.           .colorBox.v set [format %.0f [expr [lindex $colorBoxHSV 2]*1000.0]]
  2408.         }
  2409.       }
  2410.     }
  2411.   }
  2412.   .colorBox.red config \
  2413.     -command "ColorBoxSetRGBColor $colorBoxMessage \"$colorBoxTargetW\""
  2414.   .colorBox.green config \
  2415.     -command "ColorBoxSetRGBColor $colorBoxMessage \"$colorBoxTargetW\""
  2416.   .colorBox.blue config \
  2417.     -command "ColorBoxSetRGBColor $colorBoxMessage \"$colorBoxTargetW\""
  2418.   .colorBox.h config \
  2419.     -command "ColorBoxSetHSVColor $colorBoxMessage \"$colorBoxTargetW\""
  2420.   .colorBox.s config \
  2421.     -command "ColorBoxSetHSVColor $colorBoxMessage \"$colorBoxTargetW\""
  2422.   .colorBox.v config \
  2423.     -command "ColorBoxSetHSVColor $colorBoxMessage \"$colorBoxTargetW\""
  2424. }
  2425.  
  2426. ##########
  2427. # Procedure: ColorBoxSetRGBColor
  2428. # Description: set the color as RGB value
  2429. # Arguments: colorBoxMessage - the message for the color
  2430. #            colorBoxTargetW - the widget we configure
  2431. #            colorBoxValue - the passed value from scale
  2432. # Returns: none
  2433. # Sideeffects: none
  2434. ##########
  2435. proc ColorBoxSetRGBColor {colorBoxMessage colorBoxTargetW colorBoxValue} {# xf ignore me 6
  2436.   global colorBox
  2437.  
  2438.   ColorBoxSetColor $colorBoxMessage $colorBoxTargetW rgb \
  2439.     [format #%02x%02x%02x [.colorBox.red get] \
  2440.       [.colorBox.green get] [.colorBox.blue get]]
  2441.   ColorBoxSetPaletteList [format #%02x%02x%02x [.colorBox.red get] \
  2442.     [.colorBox.green get] [.colorBox.blue get]]
  2443. }
  2444.  
  2445. ##########
  2446. # Procedure: ColorBoxSetHSVColor
  2447. # Description: set the color as HSV value
  2448. # Arguments: colorBoxMessage - the message for the color
  2449. #            colorBoxTargetW - the widget we configure
  2450. #            colorBoxValue - the passed value from scale
  2451. # Returns: none
  2452. # Sideeffects: none
  2453. ##########
  2454. proc ColorBoxSetHSVColor {colorBoxMessage colorBoxTargetW colorBoxValue} {# xf ignore me 6
  2455.   global colorBox
  2456.  
  2457.   set colorBoxRGB [ColorBoxHSVToRGB [expr [.colorBox.h get]/1000.0] [expr [.colorBox.s get]/1000.0] [expr [.colorBox.v get]/1000.0]]
  2458.   ColorBoxSetColor $colorBoxMessage $colorBoxTargetW hsv \
  2459.     [format #%04x%04x%04x [lindex $colorBoxRGB 0] [lindex $colorBoxRGB 1] [lindex $colorBoxRGB 2]]
  2460.   ColorBoxSetPaletteList [format #%04x%04x%04x [lindex $colorBoxRGB 0] [lindex $colorBoxRGB 1] [lindex $colorBoxRGB 2]]
  2461. }
  2462.  
  2463. ##########
  2464. # Procedure: ColorBoxSetPalette
  2465. # Description: set the palette color
  2466. # Arguments: colorBoxMessage - the message for the color
  2467. #            colorBoxTargetW - the widget we configure
  2468. #            colorBoxElement - the palette element
  2469. # Returns: none
  2470. # Sideeffects: none
  2471. ##########
  2472. proc ColorBoxSetPalette {colorBoxMessage colorBoxTargetW colorBoxElement} {# xf ignore me 6
  2473.   global colorBox
  2474.  
  2475.   set colorBox(paletteNr) $colorBoxElement
  2476.   ColorBoxSetColor $colorBoxMessage $colorBoxTargetW palette \
  2477.     [lindex [.colorBox.palette.palette$colorBoxElement config -background] 4]
  2478. }
  2479.  
  2480. ##########
  2481. # Procedure: ColorBoxSetPaletteList
  2482. # Description: set the palette color list
  2483. # Arguments: colorBoxValue - the new palette value
  2484. # Returns: none
  2485. # Sideeffects: none
  2486. ##########
  2487. proc ColorBoxSetPaletteList {colorBoxValue} {# xf ignore me 6
  2488.   global colorBox
  2489.  
  2490.   catch ".colorBox.palette.palette$colorBox(paletteNr) config \
  2491.       -activebackground $colorBoxValue"
  2492.   catch ".colorBox.palette.palette$colorBox(paletteNr) config \
  2493.       -background $colorBoxValue"
  2494.   set colorBox(palette) \
  2495.     [lreplace $colorBox(palette) $colorBox(paletteNr) $colorBox(paletteNr) \
  2496.       $colorBoxValue]
  2497. }
  2498.  
  2499. ##########
  2500. # Procedure: ColorBoxShowSlides
  2501. # Description: select color for color composing
  2502. # Arguments: colorBoxMessage - the message for the color
  2503. #            colorBoxTargetW - the widget we configure
  2504. # Returns: none
  2505. # Sideeffects: none
  2506. ##########
  2507. proc ColorBoxShowSlides {colorBoxMessage colorBoxTargetW} {# xf ignore me 6
  2508.   global colorBox
  2509.  
  2510.   catch "pack unpack .colorBox.frame1"
  2511.   catch "pack unpack .colorBox.frame2"
  2512.   catch "pack unpack .colorBox.current"
  2513.   catch "pack unpack .colorBox.demo"
  2514.   catch "pack unpack .colorBox.h"
  2515.   catch "pack unpack .colorBox.s"
  2516.   catch "pack unpack .colorBox.v"
  2517.   catch "pack unpack .colorBox.red"
  2518.   catch "pack unpack .colorBox.green"
  2519.   catch "pack unpack .colorBox.blue"
  2520.   catch "pack unpack .colorBox.colors"
  2521.   case $colorBox(type) in {
  2522.     {rgb} {
  2523.       pack append .colorBox \
  2524.                   .colorBox.frame1 {bottom fillx} \
  2525.                   .colorBox.frame2 {bottom fillx} \
  2526.                   .colorBox.current {bottom fillx} \
  2527.                   .colorBox.palette {bottom fillx} \
  2528.                   .colorBox.red {top fillx} \
  2529.                   .colorBox.green {top fillx} \
  2530.                   .colorBox.blue {top fillx} \
  2531.                   .colorBox.demo {bottom fill expand}
  2532.     }
  2533.     {hsv} {
  2534.       pack append .colorBox \
  2535.                   .colorBox.frame1 {bottom fillx} \
  2536.                   .colorBox.frame2 {bottom fillx} \
  2537.                   .colorBox.current {bottom fillx} \
  2538.                   .colorBox.palette {bottom fillx} \
  2539.                   .colorBox.h {top fillx} \
  2540.                   .colorBox.s {top fillx} \
  2541.                   .colorBox.v {top fillx} \
  2542.                   .colorBox.demo {bottom fill expand}
  2543.     }
  2544.     {list} {
  2545.       pack append .colorBox \
  2546.                   .colorBox.frame1 {bottom fillx} \
  2547.                   .colorBox.frame2 {bottom fillx} \
  2548.                   .colorBox.current {bottom fillx} \
  2549.                   .colorBox.palette {bottom fillx} \
  2550.                   .colorBox.demo {bottom fillx} \
  2551.                   .colorBox.colors {top fill expand}
  2552.     }
  2553.   }
  2554.   if {[string match "*oreground*" $colorBoxMessage]} {
  2555.     ColorBoxSetColor $colorBoxMessage $colorBoxTargetW text \
  2556.       [lindex [.colorBox.demo config -foreground] 4]
  2557.   } {
  2558.     ColorBoxSetColor $colorBoxMessage $colorBoxTargetW text \
  2559.       [lindex [.colorBox.demo config -background] 4]
  2560.   }
  2561. }
  2562.  
  2563. ##########
  2564. # Procedure: ColorBoxHSVToRGB
  2565. # Description: modify hsv color values to rgb values
  2566. # Arguments: colorBoxHue - the hue
  2567. #            colorBoxSat - the saturation
  2568. #            colorBoxValue - the value
  2569. # Returns: none
  2570. # Sideeffects: none
  2571. ##########
  2572. proc ColorBoxHSVToRGB {colorBoxHue colorBoxSat colorBoxValue} {# xf ignore me 6
  2573. # The HSV <-> RGB converting routines are from the
  2574. # tcolor demo that is part of the demo site of Tk.
  2575.  
  2576.   set colorBoxV [format %.0f [expr 65535.0*$colorBoxValue]]
  2577.   if {$colorBoxSat == 0} {
  2578.     return "$colorBoxV $colorBoxV $colorBoxV"
  2579.   } else {
  2580.     set colorBoxHue [expr $colorBoxHue*6.0]
  2581.     if {$colorBoxHue >= 6.0} {
  2582.       set colorBoxHue 0.0
  2583.     }
  2584.     scan $colorBoxHue. %d i
  2585.     set colorBoxF [expr $colorBoxHue-$i]
  2586.     set colorBoxP [format %.0f [expr {65535.0*$colorBoxValue*(1 - $colorBoxSat)}]]
  2587.     set colorBoxQ [format %.0f [expr {65535.0*$colorBoxValue*(1 - ($colorBoxSat*$colorBoxF))}]]
  2588.     set colorBoxT [format %.0f [expr {65535.0*$colorBoxValue*(1 - ($colorBoxSat*(1 - $colorBoxF)))}]]
  2589.     case $i \
  2590.       0 {return "$colorBoxV $colorBoxT $colorBoxP"} \
  2591.       1 {return "$colorBoxQ $colorBoxV $colorBoxP"} \
  2592.       2 {return "$colorBoxP $colorBoxV $colorBoxT"} \
  2593.       3 {return "$colorBoxP $colorBoxQ $colorBoxV"} \
  2594.       4 {return "$colorBoxT $colorBoxP $colorBoxV"} \
  2595.       5 {return "$colorBoxV $colorBoxP $colorBoxQ"}
  2596.     error "i value $i is out of range"
  2597.   }
  2598. }
  2599.  
  2600. ##########
  2601. # Procedure: ColorBoxRGBToHSV
  2602. # Description: modify rgb color values to hsv values
  2603. # Arguments: colorBoxRed - the red value
  2604. #            colorBoxGreen - the green value
  2605. #            colorBoxBlue - the blue value
  2606. # Returns: none
  2607. # Sideeffects: none
  2608. ##########
  2609. proc ColorBoxRGBToHSV {colorBoxRed colorBoxGreen colorBoxBlue} {# xf ignore me 6
  2610. # The HSV <-> RGB converting routines are from the
  2611. # tcolor demo that is part of the demo site of Tk.
  2612.  
  2613.   if {$colorBoxRed > $colorBoxGreen} {
  2614.     set colorBoxMax $colorBoxRed.0
  2615.     set colorBoxMin $colorBoxGreen.0
  2616.   } else {
  2617.     set colorBoxMax $colorBoxGreen.0
  2618.     set colorBoxMin $colorBoxRed.0
  2619.   }
  2620.   if {$colorBoxBlue > $colorBoxMax} {
  2621.     set colorBoxMax $colorBoxBlue.0
  2622.   } else {
  2623.     if {$colorBoxBlue < $colorBoxMin} {
  2624.       set colorBoxMin $colorBoxBlue.0
  2625.     }
  2626.   }
  2627.   set range [expr $colorBoxMax-$colorBoxMin]
  2628.   if {$colorBoxMax == 0} {
  2629.     set colorBoxSat 0
  2630.   } else {
  2631.     set colorBoxSat [expr {($colorBoxMax-$colorBoxMin)/$colorBoxMax}]
  2632.   }
  2633.   if {$colorBoxSat == 0} {
  2634.     set colorBoxHue 0
  2635.   } else {
  2636.     set colorBoxRC [expr {($colorBoxMax - $colorBoxRed)/$range}]
  2637.     set colorBoxGC [expr {($colorBoxMax - $colorBoxGreen)/$range}]
  2638.     set colorBoxBC [expr {($colorBoxMax - $colorBoxBlue)/$range}]
  2639.     if {$colorBoxRed == $colorBoxMax} {
  2640.       set colorBoxHue [expr {.166667*($colorBoxBC - $colorBoxGC)}]
  2641.     } else {
  2642.       if {$colorBoxGreen == $colorBoxMax} {
  2643.         set colorBoxHue [expr {.166667*(2 + $colorBoxRC - $colorBoxBC)}]
  2644.       } else {
  2645.         set colorBoxHue [expr {.166667*(4 + $colorBoxGC - $colorBoxRC)}]
  2646.       }
  2647.     }
  2648.   }
  2649.   return [list $colorBoxHue $colorBoxSat [expr {$colorBoxMax/65535}]]
  2650. }
  2651.  
  2652. # eof
  2653. #
  2654.  
  2655.